Refactor code

package.yaml

@@ -91,3 +91,4 @@ tests:
     - mongoDB
     - hspec-wai
     - securemem
+    - time

src/Order.hs

@@ -0,0 +1,192 @@
+{-# 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]
+    }
+  deriving (Eq, Show, Generic)
+
+instance ToJSON ZGoOrder where
+  toJSON (ZGoOrder i a s ts c cur p t tZ l) =
+    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
+          ]
+      Nothing ->
+        object
+          [ "_id" .= ("" :: String)
+          , "address" .= a
+          , "session" .= s
+          , "timestamp" .= ts
+          , "closed" .= c
+          , "currency" .= cur
+          , "price" .= p
+          , "total" .= t
+          , "totalZec" .= tZ
+          , "lines" .= l
+          ]
+
+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"
+      pure $
+        ZGoOrder
+          (if not (null i)
+             then Just (read i)
+             else Nothing)
+          a
+          s
+          ts
+          c
+          cur
+          p
+          t
+          tZ
+          l
+
+instance Val ZGoOrder where
+  val (ZGoOrder i a s ts c cur p t tZ l) =
+    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
+             ]
+      else Doc
+             [ "address" =: a
+             , "session" =: s
+             , "timestamp" =: ts
+             , "closed" =: c
+             , "currency" =: cur
+             , "price" =: p
+             , "total" =: t
+             , "totalZec" =: tZ
+             , "lines" =: l
+             ]
+  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
+    Just (ZGoOrder i a s ts c cur p t tZ l)
+  cast' _ = Nothing
+
+-- Type to represent an order line item
+data LineItem =
+  LineItem
+    { l_id :: Maybe ObjectId
+    , lqty :: Double
+    , lname :: T.Text
+    , lcost :: Double
+    }
+  deriving (Eq, Show)
+
+instance ToJSON LineItem where
+  toJSON (LineItem i q n c) =
+    case i of
+      Just oid ->
+        object ["_id" .= show oid, "qty" .= q, "name" .= n, "cost" .= c]
+      Nothing ->
+        object ["_id" .= ("" :: String), "qty" .= q, "name" .= n, "cost" .= c]
+
+instance FromJSON LineItem where
+  parseJSON =
+    withObject "LineItem" $ \obj -> do
+      i <- obj .: "_id"
+      q <- obj .: "qty"
+      n <- obj .: "name"
+      c <- obj .: "cost"
+      pure $
+        LineItem
+          (if not (null i)
+             then Just (read i)
+             else Nothing)
+          q
+          n
+          c
+
+instance Val LineItem where
+  val (LineItem i q n c) =
+    case i of
+      Just oid -> Doc ["_id" =: oid, "qty" =: q, "name" =: n, "cost" =: c]
+      Nothing -> Doc ["qty" =: q, "name" =: n, "cost" =: c]
+  cast' (Doc d) = do
+    i <- B.lookup "_id" d
+    q <- B.lookup "qty" d
+    n <- B.lookup "name" d
+    c <- B.lookup "cost" d
+    Just (LineItem i q n c)
+  cast' _ = Nothing
+
+-- Database actions
+upsertOrder :: ZGoOrder -> Action IO ()
+upsertOrder o = do
+  let order = val o
+  case order of
+    Doc d -> upsert (select ["_id" =: q_id o] "orders") d
+    _ -> return ()
+
+findOrder :: T.Text -> Action IO (Maybe Document)
+findOrder s = findOne (select ["session" =: s] "orders")
+
+findOrderById :: String -> Action IO (Maybe Document)
+findOrderById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "orders")
+
+deleteOrder :: String -> Action IO ()
+deleteOrder i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "orders")

src/Owner.hs

@@ -0,0 +1,229 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Owner where
+
+import Data.Aeson
+import qualified Data.Bson as B
+import qualified Data.Text as T
+import Data.Typeable
+import Database.MongoDB
+import GHC.Generics
+
+-- | Type to represent a ZGo shop owner/business
+data Owner =
+  Owner
+    { o_id :: Maybe ObjectId
+    , oaddress :: T.Text
+    , oname :: T.Text
+    , ocurrency :: T.Text
+    , otax :: Bool
+    , otaxValue :: Double
+    , ovat :: Bool
+    , ovatValue :: Double
+    , ofirst :: T.Text
+    , olast :: T.Text
+    , oemail :: T.Text
+    , ostreet :: T.Text
+    , ocity :: T.Text
+    , ostate :: T.Text
+    , opostal :: T.Text
+    , ophone :: T.Text
+    , owebsite :: T.Text
+    , ocountry :: T.Text
+    , opaid :: Bool
+    , ozats :: Bool
+    , oinvoices :: Bool
+    }
+  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) =
+    case i of
+      Just oid ->
+        object
+          [ "_id" .= show oid
+          , "address" .= a
+          , "name" .= n
+          , "currency" .= c
+          , "tax" .= t
+          , "taxValue" .= tV
+          , "vat" .= v
+          , "vatValue" .= vV
+          , "first" .= f
+          , "last" .= l
+          , "email" .= e
+          , "street" .= s
+          , "city" .= ct
+          , "state" .= st
+          , "postal" .= p
+          , "phone" .= ph
+          , "website" .= w
+          , "country" .= co
+          , "paid" .= paid
+          , "zats" .= zats
+          , "invoices" .= inv
+          ]
+      Nothing ->
+        object
+          [ "_id" .= ("" :: String)
+          , "address" .= a
+          , "name" .= n
+          , "currency" .= c
+          , "tax" .= t
+          , "taxValue" .= tV
+          , "vat" .= v
+          , "vatValue" .= vV
+          , "first" .= f
+          , "last" .= l
+          , "email" .= e
+          , "street" .= s
+          , "city" .= ct
+          , "state" .= st
+          , "postal" .= p
+          , "phone" .= ph
+          , "website" .= w
+          , "country" .= co
+          , "paid" .= paid
+          , "zats" .= zats
+          , "invoices" .= inv
+          ]
+
+instance FromJSON Owner where
+  parseJSON =
+    withObject "Owner" $ \obj -> do
+      i <- obj .: "_id"
+      a <- obj .: "address"
+      n <- obj .: "name"
+      c <- obj .: "currency"
+      t <- obj .: "tax"
+      tV <- obj .: "taxValue"
+      v <- obj .: "vat"
+      vV <- obj .: "vatValue"
+      f <- obj .: "first"
+      l <- obj .: "last"
+      e <- obj .: "email"
+      s <- obj .: "street"
+      ct <- obj .: "city"
+      st <- obj .: "state"
+      p <- obj .: "postal"
+      ph <- obj .: "phone"
+      w <- obj .: "website"
+      co <- obj .: "country"
+      paid <- obj .: "paid"
+      zats <- obj .: "zats"
+      inv <- obj .: "invoices"
+      pure $
+        Owner
+          (if not (null i)
+             then Just (read i)
+             else Nothing)
+          a
+          n
+          c
+          t
+          tV
+          v
+          vV
+          f
+          l
+          e
+          s
+          ct
+          st
+          p
+          ph
+          w
+          co
+          paid
+          zats
+          inv
+
+instance Val Owner where
+  cast' (Doc d) = do
+    i <- B.lookup "_id" d
+    a <- B.lookup "address" d
+    n <- B.lookup "name" d
+    c <- B.lookup "currency" d
+    t <- B.lookup "tax" d
+    tV <- B.lookup "taxValue" d
+    v <- B.lookup "vat" d
+    vV <- B.lookup "vatValue" d
+    f <- B.lookup "first" d
+    l <- B.lookup "last" d
+    e <- B.lookup "email" d
+    s <- B.lookup "street" d
+    ct <- B.lookup "city" d
+    st <- B.lookup "state" d
+    p <- B.lookup "postal" d
+    ph <- B.lookup "phone" d
+    w <- B.lookup "website" d
+    co <- B.lookup "country" d
+    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)
+  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) =
+    case i of
+      Just oid ->
+        Doc
+          [ "_id" =: oid
+          , "address" =: a
+          , "name" =: n
+          , "currency" =: c
+          , "tax" =: t
+          , "taxValue" =: tV
+          , "vat" =: v
+          , "vatValue" =: vV
+          , "first" =: f
+          , "last" =: l
+          , "email" =: e
+          , "street" =: s
+          , "city" =: ct
+          , "state" =: st
+          , "postal" =: p
+          , "phone" =: ph
+          , "website" =: w
+          , "country" =: co
+          , "paid" =: paid
+          , "zats" =: zats
+          , "invoices" =: inv
+          ]
+      Nothing ->
+        Doc
+          [ "address" =: a
+          , "name" =: n
+          , "currency" =: c
+          , "tax" =: t
+          , "taxValue" =: tV
+          , "vat" =: v
+          , "vatValue" =: vV
+          , "first" =: f
+          , "last" =: l
+          , "email" =: e
+          , "street" =: s
+          , "city" =: ct
+          , "state" =: st
+          , "postal" =: p
+          , "phone" =: ph
+          , "website" =: w
+          , "country" =: co
+          , "paid" =: paid
+          , "zats" =: zats
+          , "invoices" =: inv
+          ]
+
+-- Database actions
+-- | Function to upsert an Owner
+upsertOwner :: Owner -> Action IO ()
+upsertOwner o = do
+  let owner = val o
+  case owner of
+    Doc d -> upsert (select ["address" =: oaddress o] "owners") d
+    _ -> return ()
+
+-- | Function to get an Owner
+findOwner :: T.Text -> Action IO (Maybe Document)
+findOwner zaddy = findOne (select ["address" =: zaddy] "owners")

src/User.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module User where
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Data.Aeson
+import qualified Data.Bson as B
+import Data.Maybe
+import qualified Data.Text as T
+import Database.MongoDB
+import GHC.Generics
+import System.IO.Unsafe
+import System.Random
+import ZGoTx
+
+-- | Type to represent a ZGo User, i.e.: a specific device
+data User =
+  User
+    { u_id :: String
+    , uaddress :: T.Text
+    , usession :: T.Text
+    , ublocktime :: Integer
+    , upin :: T.Text
+    , uvalidated :: Bool
+    }
+  deriving (Eq, Show, Generic)
+
+instance ToJSON User where
+  toJSON (User i a s bt p v) =
+    object
+      [ "_id" .= i
+      , "address" .= a
+      , "session" .= s
+      , "blocktime" .= bt
+      , "validated" .= v
+      ]
+
+instance FromJSON User where
+  parseJSON =
+    withObject "User" $ \obj -> do
+      i <- obj .: "_id"
+      a <- obj .: "address"
+      s <- obj .: "session"
+      bt <- obj .: "blocktime"
+      v <- obj .: "validated"
+      pure $ User i a s bt "" v
+
+parseUserBson :: B.Document -> Maybe User
+parseUserBson d = do
+  i <- B.lookup "_id" d
+  a <- B.lookup "address" d
+  s <- B.lookup "session" d
+  b <- B.lookup "blocktime" d
+  p <- B.lookup "pin" d
+  v <- B.lookup "validated" d
+  pure $ User (show (i :: B.ObjectId)) a s b p v
+
+-- Database Actions
+-- | Function to query DB for unexpired user by session ID
+findUser :: T.Text -> Action IO (Maybe Document)
+findUser s = findOne (select ["session" =: s] "users")
+
+-- | Function to delete user by ID
+deleteUser :: String -> Action IO ()
+deleteUser i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "users")
+
+-- | Function to verify if the given ZGoTx represents an already existing User
+isUserNew :: Pipe -> T.Text -> ZGoTx -> IO Bool
+isUserNew p db tx =
+  isNothing <$>
+  access p master db (findOne (select ["session" =: session tx] "users"))
+
+-- | Function to mark user as validated
+validateUser :: T.Text -> Action IO ()
+validateUser session =
+  modify
+    (select ["session" =: session] "users")
+    ["$set" =: ["validated" =: True]]
+
+generatePin :: IO T.Text
+generatePin = do
+  g <- newStdGen
+  pure $
+    T.pack (padLeft (show . head $ randomRs (1 :: Integer, 10000000) g) '0' 7)
+
+-- | Helper function to pad a string to a given length
+padLeft :: String -> Char -> Int -> String
+padLeft s c m =
+  let isBaseLarger = length s > m
+      padder st ch m False = [ch | _ <- [1 .. (m - length st)]] ++ s
+      padder st _ _ True = st
+   in padder s c m isBaseLarger

src/ZGoBackend.hs

@@ -19,7 +19,9 @@ import Data.SecureMem
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as L
 import Data.Time.Clock
+import Data.Typeable
 import qualified Data.Vector as V
+import Data.Word
 import Database.MongoDB
 import Debug.Trace
 import GHC.Generics
@@ -27,13 +29,17 @@ import Network.HTTP.Simple
 import Network.HTTP.Types.Status
 import Network.Wai.Middleware.HttpAuth
 import Numeric
+import Order
+import Owner
 import System.IO.Unsafe
 import System.Random
 import Test.QuickCheck
 import Test.QuickCheck.Instances
 import Text.Regex
 import Text.Regex.Base
+import User
 import Web.Scotty
+import ZGoTx
 
 -- Models for API objects
 -- | A type to model Zcash RPC calls
@@ -134,8 +140,7 @@ instance Arbitrary ZcashTx where
     bt <- arbitrary
     c <- arbitrary
     cm <- arbitrary
-    m <- arbitrary
-    return $ ZcashTx a aZ t bh bt c cm m
+    ZcashTx a aZ t bh bt c cm <$> arbitrary
 
 -- | Helper function to turn a hex-encoded memo strings to readable text
 decodeHexText :: String -> String
@@ -155,20 +160,6 @@ encodeHexText t = mconcat (map padHex t)
         then "0" ++ (showHex . ord) x ""
         else showHex (ord x) ""
 
--- | Helper function to pad a string to a given length
-padLeft :: String -> Char -> Int -> String
-padLeft s c m =
-  let isBaseLarger = length s > m
-      padder s c m False = [c | _ <- [1 .. (m - length s)]] ++ s
-      padder s _ _ True = s
-   in padder s c m isBaseLarger
-
-generatePin :: IO T.Text
-generatePin = do
-  g <- newStdGen
-  pure $
-    T.pack (padLeft (show . head $ randomRs (1 :: Integer, 10000000) g) '0' 7)
-
 -- Types for the ZGo database documents
 -- | Type to model a country for the database's country list
 data Country =
@@ -186,95 +177,6 @@ parseCountryBson d = do
   c <- B.lookup "code" d
   pure $ Country (show (i :: B.ObjectId)) n c
 
--- | Type to represent a ZGo User, i.e.: a specific device
-data User =
-  User
-    { u_id :: String
-    , uaddress :: T.Text
-    , usession :: T.Text
-    , ublocktime :: Integer
-    , upin :: T.Text
-    , uvalidated :: Bool
-    }
-  deriving (Eq, Show, Generic)
-
-instance ToJSON User where
-  toJSON (User i a s bt p v) =
-    object
-      [ "_id" .= i
-      , "address" .= a
-      , "session" .= s
-      , "blocktime" .= bt
-      , "validated" .= v
-      ]
-
-instance FromJSON User where
-  parseJSON =
-    withObject "User" $ \obj -> do
-      i <- obj .: "_id"
-      a <- obj .: "address"
-      s <- obj .: "session"
-      bt <- obj .: "blocktime"
-      v <- obj .: "validated"
-      pure $ User i a s bt "" v
-
-parseUserBson :: B.Document -> Maybe User
-parseUserBson d = do
-  i <- B.lookup "_id" d
-  a <- B.lookup "address" d
-  s <- B.lookup "session" d
-  b <- B.lookup "blocktime" d
-  p <- B.lookup "pin" d
-  v <- B.lookup "validated" d
-  pure $ User (show (i :: B.ObjectId)) a s b p v
-
--- | Type to model a ZGo transaction
-data ZGoTx =
-  ZGoTx
-    { _id :: String
-    , address :: T.Text
-    , session :: T.Text
-    , confirmations :: Integer
-    , blocktime :: Integer
-    , amount :: Double
-    , txid :: T.Text
-    , memo :: T.Text
-    }
-  deriving (Eq, Show, Generic, ToJSON)
-
-parseZGoTxBson :: B.Document -> Maybe ZGoTx
-parseZGoTxBson 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
-  pure $ ZGoTx (show (i :: B.ObjectId)) 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" =: i
-         , "address" =: a
-         , "session" =: s
-         , "confirmations" =: c
-         , "blocktime" =: bt
-         , "amount" =: am
-         , "txid" =: t
-         , "memo" =: m
-         ]
-    else [ "address" =: a
-         , "session" =: s
-         , "confirmations" =: c
-         , "blocktime" =: bt
-         , "amount" =: am
-         , "txid" =: t
-         , "memo" =: m
-         ]
-
 zToZGoTx :: ZcashTx -> ZGoTx
 zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
   let r =
@@ -287,14 +189,14 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do
   let reg2 = matchAllText p (T.unpack m)
   if not (null reg)
     then do
-      let session = T.pack (fst $ head reg ! 1)
+      let sess = T.pack (fst $ head reg ! 1)
       let addy = T.pack (fst $ head reg ! 2)
-      ZGoTx "" addy session conf bt a t m
+      ZGoTx "" addy sess conf bt a t m
     else do
       if not (null reg2)
         then do
-          let session = T.pack (fst $ head reg2 ! 1)
-          ZGoTx "" "" session conf bt a t m
+          let sess = T.pack (fst $ head reg2 ! 1)
+          ZGoTx "" "" sess conf bt a t m
         else ZGoTx "" "" "" conf bt a t m
 
 -- |Type to model a price in the ZGo database
@@ -331,44 +233,6 @@ instance FromJSON CoinGeckoPrices where
 listCountries :: Action IO [Document]
 listCountries = rest =<< find (select [] "countries")
 
--- | Function to query DB for unexpired user by session ID
-findUser :: T.Text -> Action IO (Maybe Document)
-findUser s = findOne (select ["session" =: s] "users")
-
--- | Function to create user from ZGoTx
-addUser :: Pipe -> T.Text -> T.Text -> Maybe ZGoTx -> Action IO ()
-addUser _ _ _ Nothing = return () --`debug` "addUser got Nothing"
-addUser p db node (Just tx) = do
-  isNew <- liftIO $ isUserNew p db tx
-  when isNew $ do
-    let newPin = unsafePerformIO generatePin
-    _ <- sendPin node (address tx) newPin
-    insert_
-      "users"
-      [ "address" =: address tx
-      , "session" =: session tx
-      , "blocktime" =: blocktime tx
-      , "pin" =: newPin
-      , "validated" =: False
-      ]
-
--- | Function to delete user by ID
-deleteUser :: String -> Action IO ()
-deleteUser i = deleteOne (select ["_id" =: (read i :: B.ObjectId)] "users")
-
--- | Function to verify if the given ZGoTx represents an already existing User
-isUserNew :: Pipe -> T.Text -> ZGoTx -> IO Bool
-isUserNew p db tx =
-  isNothing <$>
-  access p master db (findOne (select ["session" =: session tx] "users"))
-
--- | Function to mark user as validated
-validateUser :: T.Text -> Action IO ()
-validateUser session =
-  modify
-    (select ["session" =: session] "users")
-    ["$set" =: ["validated" =: True]]
-
 sendPin :: T.Text -> T.Text -> T.Text -> Action IO String
 sendPin nodeAddress addr pin = do
   let payload =
@@ -388,6 +252,23 @@ sendPin nodeAddress addr pin = do
     then return "Pin sent!"
     else return "Pin sending failed :("
 
+-- | Function to create user from ZGoTx
+addUser :: Pipe -> T.Text -> T.Text -> Maybe ZGoTx -> Action IO ()
+addUser _ _ _ Nothing = return () --`debug` "addUser got Nothing"
+addUser p db node (Just tx) = do
+  isNew <- liftIO $ isUserNew p db tx
+  when isNew $ do
+    let newPin = unsafePerformIO generatePin
+    _ <- sendPin node (address tx) newPin
+    insert_
+      "users"
+      [ "address" =: address tx
+      , "session" =: session tx
+      , "blocktime" =: blocktime tx
+      , "pin" =: newPin
+      , "validated" =: False
+      ]
+
 -- | Function to query DB for transactions with less than 10 confirmations
 findPending :: String -> Action IO [Document]
 findPending s =
@@ -441,8 +322,8 @@ app pipe db passkey nodeAddress = do
                ])
     --Get user associated with session
     get "/api/user" $ do
-      session <- param "session"
-      user <- liftIO $ run (findUser session)
+      sess <- param "session"
+      user <- liftIO $ run (findUser sess)
       case user of
         Nothing -> status noContent204
         Just u ->
@@ -454,21 +335,23 @@ app pipe db passkey nodeAddress = do
     --Validate user, updating record
     post "/api/validateuser" $ do
       providedPin <- param "pin"
-      session <- param "session"
-      user <- liftIO $ run (findUser session)
+      sess <- param "session"
+      user <- liftIO $ run (findUser sess)
       case user of
-        Nothing -> status noContent204
+        Nothing -> status noContent204 --`debug` "No user match"
         Just u -> do
           let parsedUser = parseUserBson u
           case parsedUser of
-            Nothing -> status noContent204
+            Nothing -> status noContent204 --`debug` "Couldn't parse user"
             Just pUser -> do
-              let result = upin pUser == providedPin
-              if result
+              let ans = upin pUser == T.pack providedPin
+              if ans
                 then do
-                  liftIO $ run (validateUser session)
+                  liftIO $ run (validateUser sess)
                   status accepted202
-                else status noContent204
+                else status noContent204 `debug`
+                     ("Pins didn't match: " ++
+                      providedPin ++ " " ++ T.unpack (upin pUser))
     --Delete user
     Web.Scotty.delete "/api/user/:id" $ do
       userId <- param "id"
@@ -476,8 +359,8 @@ app pipe db passkey nodeAddress = do
       status ok200
     --Get txs from DB that have less than 10 confirmations
     get "/api/pending" $ do
-      session <- param "session"
-      pending <- liftIO $ run (findPending session)
+      sess <- param "session"
+      pending <- liftIO $ run (findPending sess)
       case pending of
         [] -> do
           status noContent204
@@ -498,9 +381,27 @@ app pipe db passkey nodeAddress = do
     --Get the ZGo node's shielded address
     get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
     --Get owner by address
-    get "/api/owner" $ do text "Here's an owner for you"
+    get "/api/owner" $ do
+      addr <- param "address"
+      owner <- liftIO $ run (findOwner addr)
+      case owner of
+        Nothing -> status noContent204
+        Just o -> do
+          let pOwner = cast' (Doc o)
+          case pOwner of
+            Nothing -> status internalServerError500
+            Just q -> do
+              status ok200
+              Web.Scotty.json
+                (object
+                   [ "message" .= ("Owner found!" :: String)
+                   , "owner" .= toJSON (q :: Owner)
+                   ])
     --Upsert owner to DB
-    post "/api/owner" $ do text "I added an owner for you"
+    post "/api/owner" $ do
+      o <- jsonData
+      _ <- liftIO $ run (upsertOwner o)
+      status created201
     --Get items associated with the given address
     get "/api/items" $ do text "Here are your items"
     --Upsert item
@@ -509,9 +410,9 @@ app pipe db passkey nodeAddress = do
     Web.Scotty.delete "/api/item/:id" $ do text "Deleted that pesky item"
     --Get price for Zcash
     get "/api/price" $ do
-      currency <- param "currency"
-      price <- liftIO $ run (findPrice currency)
-      case price of
+      curr <- param "currency"
+      pr <- liftIO $ run (findPrice curr)
+      case pr of
         Nothing -> do
           status noContent204
           --Web.Scotty.json (object ["message" .= ("No price" :: T.Text)])
@@ -526,13 +427,47 @@ app pipe db passkey nodeAddress = do
     --Get order by id for receipts
     get "/api/order/:id" $ do
       oId <- param "id"
-      text (L.pack ("Here's the order" <> oId))
+      myOrder <- liftIO $ run (findOrderById oId)
+      case myOrder of
+        Nothing -> status noContent204
+        Just o -> do
+          let o' = cast' (Doc o)
+          case o' of
+            Nothing -> status internalServerError500
+            Just pOrder -> do
+              status ok200
+              Web.Scotty.json
+                (object
+                   [ "message" .= ("Order found!" :: String)
+                   , "order" .= toJSON (pOrder :: ZGoOrder)
+                   ])
     --Get order by session
     get "/api/order" $ do
-      diff <- param "diff"
-      text (L.pack ("This is a diff order" <> diff))
+      sess <- param "session"
+      myOrder <- liftIO $ run (findOrder sess)
+      case myOrder of
+        Nothing -> status noContent204
+        Just o -> do
+          let o' = cast' (Doc o)
+          case o' of
+            Nothing -> status internalServerError500
+            Just pOrder -> do
+              status ok200
+              Web.Scotty.json
+                (object
+                   [ "message" .= ("Order found!" :: String)
+                   , "order" .= toJSON (pOrder :: ZGoOrder)
+                   ])
     --Upsert order
-    post "/api/order" $ do text "Upserted your order"
+    post "/api/order" $ do
+      newOrder <- jsonData
+      _ <- liftIO $ run (upsertOrder newOrder)
+      status created201
+    --Delete order
+    Web.Scotty.delete "/api/order/:id" $ do
+      oId <- param "id"
+      liftIO $ run (deleteOrder oId)
+      status ok200
 
 -- |Make a Zcash RPC call
 makeZcashCall ::
@@ -575,10 +510,10 @@ checkZcashPrices p db = do
 -- | Function to check the ZGo full node for new txs
 scanZcash :: T.Text -> Pipe -> T.Text -> IO ()
 scanZcash addr pipe db = do
-  r <- makeZcashCall "z_listreceivedbyaddress" [Data.Aeson.String addr]
+  res <- makeZcashCall "z_listreceivedbyaddress" [Data.Aeson.String addr]
   let txs =
         filter (not . zchange) $
-        result (getResponseBody r :: RpcResponse [ZcashTx])
+        result (getResponseBody res :: RpcResponse [ZcashTx])
   let r =
         mkRegex
           ".*ZGO::([0-9a-fA-F]{8}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{4}\\b-[0-9a-fA-F]{12})\\sReply-To:\\s(zs[a-z0-9]{76}).*"

src/ZGoTx.hs

@@ -0,0 +1,59 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module ZGoTx where
+
+import Data.Aeson
+import qualified Data.Bson as B
+import qualified Data.Text as T
+import Database.MongoDB
+import GHC.Generics
+
+-- | Type to model a ZGo transaction
+data ZGoTx =
+  ZGoTx
+    { _id :: String
+    , address :: T.Text
+    , session :: T.Text
+    , confirmations :: Integer
+    , blocktime :: Integer
+    , amount :: Double
+    , txid :: T.Text
+    , memo :: T.Text
+    }
+  deriving (Eq, Show, Generic, ToJSON)
+
+parseZGoTxBson :: B.Document -> Maybe ZGoTx
+parseZGoTxBson 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
+  pure $ ZGoTx (show (i :: B.ObjectId)) 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)
+         , "address" =: a
+         , "session" =: s
+         , "confirmations" =: c
+         , "blocktime" =: bt
+         , "amount" =: am
+         , "txid" =: t
+         , "memo" =: m
+         ]
+    else [ "address" =: a
+         , "session" =: s
+         , "confirmations" =: c
+         , "blocktime" =: bt
+         , "amount" =: am
+         , "txid" =: t
+         , "memo" =: m
+         ]

test/Spec.hs

@@ -12,16 +12,22 @@ import Data.Either
 import Data.Maybe
 import Data.SecureMem
 import qualified Data.Text as T
+import Data.Time.Clock
 import Database.MongoDB
 import Network.HTTP.Simple
 import Network.HTTP.Types.Status
+import Order
+import Owner
 import System.IO.Unsafe
 import Test.Hspec
 import Test.Hspec.Expectations.Json
 import Test.Hspec.QuickCheck
 import Test.QuickCheck
 import Test.QuickCheck.Gen
+import Test.QuickCheck.Monadic
+import User
 import ZGoBackend
+import ZGoTx
 
 passkey :: SecureMem
 passkey = secureMemFromByteString "superSecret"
@@ -102,7 +108,7 @@ main =
             req <-
               testGet
                 "/api/user"
-                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca")]
+                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
             res <- httpJSON req
             getResponseStatus (res :: Response A.Value) `shouldBe` ok200
           it "returns 204 when no user" $ do
@@ -115,9 +121,9 @@ main =
           it "validate with correct pin" $ do
             req <-
               testPost
-                "/api/validateuser/"
-                [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdca")
-                , ("pin", Just "5989845")
+                "/api/validateuser"
+                [ ("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")
+                , ("pin", Just "1234567")
                 ]
             res <- httpLBS req
             getResponseStatus res `shouldBe` accepted202
@@ -126,13 +132,35 @@ main =
             res <- httpLBS req
             getResponseStatus res `shouldBe` ok200
         describe "Owner endpoint" $ do
-          it "add owner" $ do pending
-          it "return owner" $ do pending
+          prop "add owner" testOwnerAdd
+          it "return owner" $ do
+            req <-
+              testGet
+                "/api/owner"
+                [ ( "address"
+                  , Just
+                      "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e")
+                ]
+            res <- httpJSON req
+            getResponseStatus (res :: Response A.Value) `shouldBe` ok200
         describe "Order endpoint" $ do
-          it "upsert order" $ do pending
-          it "get order by session" $ do pending
-          it "get order by id" $ do pending
+          prop "upsert order" testOrderAdd
+          it "get order by session" $ do
+            req <-
+              testGet
+                "/api/order"
+                [("session", Just "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd")]
+            res <- httpJSON req
+            getResponseStatus (res :: Response A.Value) `shouldBe` ok200
+          it "get order by id" $ do
+            req <- testGet "/api/order/627ab3ea2b05a76be3000000" []
+            res <- httpJSON req
+            getResponseStatus (res :: Response A.Value) `shouldBe` ok200
           it "get all orders for owner" $ do pending
+          it "delete order by id" $ do
+            req <- testDelete "/api/order/" "627ab3ea2b05a76be3000000"
+            res <- httpLBS req
+            getResponseStatus res `shouldBe` ok200
     around handleDb $
       describe "Database actions" $ do
         describe "authentication" $ do
@@ -164,6 +192,41 @@ main =
                           Just r2 -> do
                             let t2 = ZGoBackend.timestamp r2
                             t2 `shouldSatisfy` (t1 <)
+        describe "user is" $ do
+          it "validated" $ \p -> do
+            t <-
+              access p master "test" $
+              findOne (select ["validated" =: False] "users")
+            case t of
+              Nothing -> True `shouldBe` False
+              Just r -> do
+                let s = parseUserBson r
+                case s of
+                  Nothing -> True `shouldBe` False
+                  Just z -> do
+                    _ <- access p master "test" $ validateUser (usession z)
+                    q <-
+                      access p master "test" $
+                      findOne
+                        (select
+                           ["validated" =: True, "session" =: usession z]
+                           "users")
+                    isNothing q `shouldBe` False
+          it "deleted" $ \p -> do
+            t <- access p master "test" $ findOne (select [] "users")
+            case t of
+              Nothing -> True `shouldBe` False
+              Just r -> do
+                let s = parseUserBson r
+                case s of
+                  Nothing -> True `shouldBe` False
+                  Just z -> do
+                    _ <- access p master "test" $ deleteUser (u_id z)
+                    q <-
+                      access p master "test" $
+                      findOne
+                        (select ["_id" =: (read (u_id z) :: ObjectId)] "users")
+                    isNothing q `shouldBe` True
         describe "Zcash transactions" $ do
           it "logins are added to db" $ \p -> do
             _ <- access p master "test" (delete (select [] "txs"))
@@ -212,41 +275,6 @@ main =
                 case s of
                   Nothing -> True `shouldBe` False
                   Just z -> length (T.unpack (usession z)) `shouldSatisfy` (> 0)
-        describe "user is" $ do
-          it "validated" $ \p -> do
-            t <-
-              access p master "test" $
-              findOne (select ["validated" =: False] "users")
-            case t of
-              Nothing -> True `shouldBe` False
-              Just r -> do
-                let s = parseUserBson r
-                case s of
-                  Nothing -> True `shouldBe` False
-                  Just z -> do
-                    _ <- access p master "test" $ validateUser (usession z)
-                    q <-
-                      access p master "test" $
-                      findOne
-                        (select
-                           ["validated" =: True, "session" =: usession z]
-                           "users")
-                    isNothing q `shouldBe` False
-          it "deleted" $ \p -> do
-            t <- access p master "test" $ findOne (select [] "users")
-            case t of
-              Nothing -> True `shouldBe` False
-              Just r -> do
-                let s = parseUserBson r
-                case s of
-                  Nothing -> True `shouldBe` False
-                  Just z -> do
-                    _ <- access p master "test" $ deleteUser (u_id z)
-                    q <-
-                      access p master "test" $
-                      findOne
-                        (select ["_id" =: (read (u_id z) :: ObjectId)] "users")
-                    isNothing q `shouldBe` True
 
 testGet :: B.ByteString -> [(B.ByteString, Maybe B.ByteString)] -> IO Request
 testGet endpoint body = do
@@ -270,6 +298,17 @@ testPost endpoint body = do
         setRequestMethod "POST" $ setRequestPath endpoint defaultRequest
   return testRequest
 
+testPostJson :: B.ByteString -> A.Value -> IO Request
+testPostJson endpoint body = do
+  let user = "user"
+  let pwd = "superSecret"
+  let testRequest =
+        setRequestBodyJSON body $
+        setRequestPort 4000 $
+        setRequestBasicAuth user pwd $
+        setRequestMethod "POST" $ setRequestPath endpoint defaultRequest
+  return testRequest
+
 testDelete :: B.ByteString -> B.ByteString -> IO Request
 testDelete endpoint par = do
   let user = "user"
@@ -281,6 +320,20 @@ testDelete endpoint par = do
         setRequestPath (B.append endpoint par) defaultRequest
   return testRequest
 
+testOwnerAdd :: Owner -> Property
+testOwnerAdd o =
+  monadicIO $ do
+    req <- run $ testPostJson "/api/owner" (A.toJSON o) --`debug` show o
+    res <- httpLBS req
+    assert $ getResponseStatus res == created201
+
+testOrderAdd :: ZGoOrder -> Property
+testOrderAdd o =
+  monadicIO $ do
+    req <- run $ testPostJson "/api/order" (A.toJSON o)
+    res <- httpLBS req
+    assert $ getResponseStatus res == created201
+
 -- | Open the MongoDB connection
 openDbConnection :: IO Pipe
 openDbConnection = do
@@ -302,5 +355,121 @@ startAPI = do
   pipe <- connect $ host "127.0.0.1"
   c <- access pipe master "zgo" (auth "zgo" "zcashrules")
   _ <- forkIO (app pipe "test" passkey nodeAddress)
+  let myUser =
+        User
+          "6272a90f2b05a74cf1000001"
+          "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
+          "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
+          1613487
+          "1234567"
+          False
+  _ <-
+    access
+      pipe
+      master
+      "test"
+      (insert_
+         "users"
+         [ "address" =: uaddress myUser
+         , "_id" =: (read (u_id myUser) :: ObjectId)
+         , "session" =: usession myUser
+         , "blocktime" =: ublocktime myUser
+         , "pin" =: upin myUser
+         , "validated" =: uvalidated myUser
+         ])
+  let myOwner =
+        Owner
+          (Just (read "627ad3492b05a76be3000001"))
+          "zs1w6nkameazc5gujm69350syl5w8tgvyaphums3pw8eytzy5ym08x7dvskmykkatmwrucmgv3er8e"
+          "Test shop"
+          "usd"
+          False
+          0
+          False
+          0
+          "Bubba"
+          "Gibou"
+          "bubba@zgo.cash"
+          "1 Main St"
+          "Mpls"
+          "Minnesota"
+          "55401"
+          ""
+          "bubbarocks.io"
+          "United States"
+          False
+          False
+          False
+  _ <- access pipe master "test" (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"))
+  myTs <- liftIO getCurrentTime
+  let myOrder =
+        ZGoOrder
+          (Just (read "627ab3ea2b05a76be3000000"))
+          "Zaddy"
+          "35bfb9c2-9ad2-4fe5-adda-99d63b8dcdcd"
+          myTs
+          False
+          "usd"
+          102.0
+          0
+          0
+          []
+  let ordTest = val myOrder
+  case ordTest of
+    Doc oT -> access pipe master "test" (insert_ "orders" oT)
   threadDelay 1000000
   putStrLn "Test server is up!"
+
+--QuickCheck instances
+instance Arbitrary ZGoOrder where
+  arbitrary = do
+    i <- arbitrary
+    a <- arbitrary
+    s <- arbitrary
+    ts <- arbitrary
+    c <- arbitrary
+    cur <- arbitrary
+    p <- arbitrary
+    t <- arbitrary
+    tZ <- arbitrary
+    ZGoOrder i a s ts c cur p t tZ <$> arbitrary
+
+instance Arbitrary LineItem where
+  arbitrary = do
+    i <- arbitrary
+    q <- arbitrary
+    n <- arbitrary
+    LineItem i q n <$> arbitrary
+
+instance Arbitrary ObjectId where
+  arbitrary = do
+    x <- arbitrary
+    Oid x <$> arbitrary
+
+instance Arbitrary Owner where
+  arbitrary = do
+    i <- arbitrary
+    a <- arbitrary
+    n <- arbitrary
+    c <- arbitrary
+    t <- arbitrary
+    tV <- arbitrary
+    v <- arbitrary
+    vV <- arbitrary
+    f <- arbitrary
+    l <- arbitrary
+    e <- arbitrary
+    s <- arbitrary
+    ct <- arbitrary
+    st <- arbitrary
+    p <- arbitrary
+    ph <- arbitrary
+    w <- arbitrary
+    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

zgo-backend.cabal

@@ -25,7 +25,11 @@ source-repository head
 
 library
   exposed-modules:
+      Order
+      Owner
+      User
       ZGoBackend
+      ZGoTx
   other-modules:
       Paths_zgo_backend
   hs-source-dirs:
@@ -96,5 +100,6 @@ test-suite zgo-backend-test
     , mongoDB
     , securemem
     , text
+    , time
     , zgo-backend
   default-language: Haskell2010