From db0787ac326bb77955b7e6d34055d7591caec9b6 Mon Sep 17 00:00:00 2001 From: Rene Vergara Date: Mon, 20 May 2024 08:39:52 -0500 Subject: [PATCH] Code refactor for update libraries --- src/ZGoBackend.hs | 376 +++++++++++++++++++++++----------------------- zgo-backend.cabal | 34 ++--- 2 files changed, 197 insertions(+), 213 deletions(-) diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index a5a0bac..29f62ef 100644 --- a/src/ZGoBackend.hs +++ b/src/ZGoBackend.hs @@ -62,7 +62,7 @@ import Text.Megaparsec (runParser) import Text.Regex import Text.Regex.Base import User -import Web.Scotty +import Web.Scotty hiding (getResponseStatus) import WooCommerce import Xero import ZGoTx @@ -91,8 +91,8 @@ instance (FromJSON r) => FromJSON (Payload r) where -- | Type to model a (simplified) block of Zcash blockchain data Block = Block - { height :: Integer - , size :: Integer + { height :: !Integer + , size :: !Integer } deriving (Show, Generic, ToJSON) instance FromJSON Block where @@ -101,14 +101,14 @@ instance FromJSON Block where -- | Type to model a Zcash shielded transaction data ZcashTx = ZcashTx - { ztxid :: T.Text - , zamount :: Double - , zamountZat :: Integer - , zblockheight :: Integer - , zblocktime :: Integer - , zchange :: Bool - , zconfirmations :: Integer - , zmemo :: T.Text + { ztxid :: !HexString + , zamount :: !Double + , zamountZat :: !Integer + , zblockheight :: !Integer + , zblocktime :: !Integer + , zchange :: !Bool + , zconfirmations :: !Integer + , zmemo :: !T.Text } deriving (Show, Generic) instance FromJSON ZcashTx where @@ -155,14 +155,14 @@ instance Arbitrary ZcashTx where bt <- arbitrary c <- arbitrary cm <- arbitrary - ZcashTx a aZ t bh bt c cm <$> arbitrary + ZcashTx (HexString a) aZ t bh bt c cm <$> arbitrary -- | A type to model an address group data AddressGroup = AddressGroup - { agsource :: AddressSource - , agtransparent :: [ZcashAddress] - , agsapling :: [ZcashAddress] - , agunified :: [ZcashAddress] + { agsource :: !AddressSource + , agtransparent :: ![ZcashAddress] + , agsapling :: ![ZcashAddress] + , agunified :: ![ZcashAddress] } deriving (Show, Generic) instance FromJSON AddressGroup where @@ -245,10 +245,10 @@ instance FromJSON ZcashPool where _ -> fail "Not a known Zcash pool" data ZcashAddress = ZcashAddress - { source :: AddressSource - , pool :: [ZcashPool] - , account :: Maybe Integer - , addy :: T.Text + { source :: !AddressSource + , pool :: ![ZcashPool] + , account :: !(Maybe Integer) + , addy :: !T.Text } deriving (Eq) instance Show ZcashAddress where @@ -269,14 +269,14 @@ decodeHexText h = E.decodeUtf8With lenientDecode $ BS.pack $ hexRead h -- | Helper function to turn a string into a hex-encoded string encodeHexText :: T.Text -> String -encodeHexText t = T.unpack . toText . fromBytes $ E.encodeUtf8 t +encodeHexText t = T.unpack . toText . fromRawBytes $ E.encodeUtf8 t -- Types for the ZGo database documents -- | Type to model a country for the database's country list data Country = Country - { _id :: String - , name :: T.Text - , code :: T.Text + { _id :: !String + , name :: !T.Text + , code :: !T.Text } deriving (Eq, Show, Generic, ToJSON) parseCountryBson :: B.Document -> Maybe Country @@ -304,24 +304,24 @@ zToZGoTx (ZcashTx t a aZ bh bt c conf m) = do then do let sess = T.pack (fst $ head reg ! 1) let nAddy = T.pack (fst $ head reg ! 2) - ZGoTx Nothing nAddy sess conf bt a t m + ZGoTx Nothing nAddy sess conf bt a (toText t) m else do if not (null reg2) then do let sess = T.pack (fst $ head reg2 ! 1) - ZGoTx Nothing "" sess conf bt a t m + ZGoTx Nothing "" sess conf bt a (toText t) m else do if not (null reg3) then do let sess = T.pack (fst $ head reg3 ! 2) let nAddy = T.pack (fst $ head reg3 ! 1) - ZGoTx Nothing nAddy sess conf bt a t m - else ZGoTx Nothing "" "" conf bt a t m + ZGoTx Nothing nAddy sess conf bt a (toText t) m + else ZGoTx Nothing "" "" conf bt a (toText t) m zToZGoTx' :: Config -> Pipe -> ZcashTx -> IO () zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do when (conf < c_confirmations config) $ do - let zM = runParser pZGoMemo (T.unpack t) m + let zM = runParser pZGoMemo (T.unpack . toText $ t) m case zM of Right zM' -> do print zM' @@ -333,7 +333,7 @@ zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do conf bt a - t + (toText t) m if m_payment zM' then upsertPayment pipe (c_dbName config) tx @@ -342,10 +342,10 @@ zToZGoTx' config pipe (ZcashTx t a aZ bh bt c conf m) = do -- |Type to model a price in the ZGo database data ZGoPrice = ZGoPrice - { _id :: String - , currency :: T.Text - , price :: Double - , timestamp :: UTCTime + { _id :: !String + , currency :: !T.Text + , price :: !Double + , timestamp :: !UTCTime } deriving (Eq, Show, Generic, ToJSON) parseZGoPrice :: B.Document -> Maybe ZGoPrice @@ -408,9 +408,9 @@ sendPin nodeUser nodePwd nodeAddress addr pin = do -- | Type for Operation Result data OpResult = OpResult - { opsuccess :: T.Text - , opmessage :: Maybe T.Text - , optxid :: Maybe T.Text + { opsuccess :: !T.Text + , opmessage :: !(Maybe T.Text) + , optxid :: !(Maybe T.Text) } deriving (Show, Eq) instance FromJSON OpResult where @@ -469,6 +469,7 @@ addUser nodeUser nodePwd p db node (Just tx) = do _ <- liftIO $ sendPin nodeUser nodePwd node (address tx) (T.pack newPin) let pinHash = BLK.hash + Nothing [ BA.pack . BS.unpack . C.pack . T.unpack $ T.pack newPin <> session tx :: BA.Bytes ] @@ -607,19 +608,18 @@ routes pipe config = do middleware $ zgoAuth pipe $ c_dbName config --Get list of countries for UI get "/api/countries" $ do - countries <- liftAndCatchIO $ run listCountries - case countries of - [] -> do - status noContent204 - _ -> do + countries <- liftIO $ run listCountries + if not (null countries) + then do Web.Scotty.json (object [ "message" .= ("Country data found" :: String) , "countries" .= toJSON (map parseCountryBson countries) ]) + else status noContent204 --Get Xero credentials get "/api/xero" $ do - xeroConfig <- liftAndCatchIO $ run findXero + xeroConfig <- liftIO $ run findXero case xeroConfig of Nothing -> status noContent204 Just x -> do @@ -634,10 +634,10 @@ routes pipe config = do , "xeroConfig" .= toJSON (c :: Xero) ]) get "/api/xerotoken" $ do - code <- param "code" - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) - xeroConfig <- liftAndCatchIO $ run findXero + code <- formParam "code" + session <- formParam "session" + user <- liftIO $ run (findUser session) + xeroConfig <- liftIO $ run findXero case cast' . Doc =<< xeroConfig of Nothing -> status noContent204 Just c -> do @@ -645,14 +645,14 @@ routes pipe config = do Nothing -> status unauthorized401 Just u -> do res <- - liftAndCatchIO $ + liftIO $ requestXeroToken pipe (c_dbName config) c code $ uaddress u if res then status ok200 else status noContent204 post "/invdata" $ do invData <- jsonData - xeroConfig <- liftAndCatchIO $ run findXero + xeroConfig <- liftIO $ run findXero let invReq = payload (invData :: Payload XeroInvoiceRequest) case cast' . Doc =<< xeroConfig of Nothing -> do @@ -664,7 +664,7 @@ routes pipe config = do , "shop" .= (Nothing :: Maybe String) ]) Just c -> do - o <- liftAndCatchIO $ run $ findOwnerById $ xr_owner invReq + o <- liftIO $ run $ findOwnerById $ xr_owner invReq case cast' . Doc =<< o of Nothing -> do status ok200 @@ -676,7 +676,7 @@ routes pipe config = do ]) Just o' -> do existingOrder <- - liftAndCatchIO $ + liftIO $ run $ findXeroOrder (oaddress o') @@ -685,12 +685,12 @@ routes pipe config = do case cast' . Doc =<< existingOrder of Nothing -> do res <- - liftAndCatchIO $ + liftIO $ requestXeroToken pipe (c_dbName config) c "none" $ oaddress o' if res then do resInv <- - liftAndCatchIO $ + liftIO $ getXeroInvoice pipe (c_dbName config) (xr_invNo invReq) $ oaddress o' case resInv of @@ -712,7 +712,7 @@ routes pipe config = do now <- liftIO getCurrentTime tk <- liftIO generateToken pr <- - liftAndCatchIO $ + liftIO $ run (findPrice $ T.unpack . ocurrency $ o') @@ -765,11 +765,11 @@ routes pipe config = do 0 0 _ <- - liftAndCatchIO $ + liftIO $ run $ upsertOrder newOrder 0 0 finalOrder <- - liftAndCatchIO $ + liftIO $ run $ findXeroOrder (oaddress o') @@ -850,12 +850,12 @@ routes pipe config = do ]) -- Get the xeroaccount code get "/api/xeroaccount" $ do - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - res <- liftAndCatchIO $ run (findToken $ uaddress u) + res <- liftIO $ run (findToken $ uaddress u) let c = cast' . Doc =<< res case c of Nothing -> status noContent204 @@ -868,27 +868,27 @@ routes pipe config = do ]) -- Save the xeroaccount code post "/api/xeroaccount" $ do - session <- param "session" - c <- param "code" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + c <- formParam "code" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do let oAdd = uaddress u - liftAndCatchIO $ run (addAccCode oAdd c) + liftIO $ run (addAccCode oAdd c) status accepted202 -- Get the WooCommerce token get "/api/wootoken" $ do - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - owner <- liftAndCatchIO $ run (findOwner $ uaddress u) + owner <- liftIO $ run (findOwner $ uaddress u) case cast' . Doc =<< owner of Nothing -> status internalServerError500 Just o -> do - res <- liftAndCatchIO $ run (findWooToken $ o_id o) + res <- liftIO $ run (findWooToken $ o_id o) let t1 = cast' . Doc =<< res case t1 of Nothing -> status noContent204 @@ -901,28 +901,28 @@ routes pipe config = do , "siteurl" .= w_url t ]) post "/api/wootoken" $ do - oid <- param "ownerid" - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + oid <- formParam "ownerid" + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - res <- liftAndCatchIO $ run (findOwnerById oid) + res <- liftIO $ run (findOwnerById oid) case cast' . Doc =<< res of Nothing -> status badRequest400 Just o -> do if oaddress o == uaddress u then do tk <- liftIO generateToken - liftAndCatchIO $ run (generateWooToken o tk) + liftIO $ run (generateWooToken o tk) status accepted202 else status forbidden403 -- Authenticate the WooCommerce plugin get "/auth" $ do - oid <- param "ownerid" - t <- param "token" - siteurl <- param "siteurl" - res <- liftAndCatchIO $ run (findWooToken $ Just (read oid)) + oid <- queryParam "ownerid" + t <- queryParam "token" + siteurl <- queryParam "siteurl" + res <- liftIO $ run (findWooToken $ Just (read oid)) let c1 = cast' . Doc =<< res case c1 of Nothing -> do @@ -934,7 +934,7 @@ routes pipe config = do if blk3Hash t == blk3Hash (T.unpack $ w_token c) then if isNothing (w_url c) then do - liftAndCatchIO $ run (addUrl c siteurl) + liftIO $ run (addUrl c siteurl) status ok200 Web.Scotty.json (object @@ -972,18 +972,20 @@ routes pipe config = do where blk3Hash :: String -> String blk3Hash s = show - (BLK.hash [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest + (BLK.hash + Nothing + [BA.pack . BS.unpack . C.pack $ s :: BA.Bytes] :: BLK.Digest BLK.DEFAULT_DIGEST_LEN) get "/woopayment" $ do - oid <- param "ownerid" - t <- param "token" - ordId <- param "order_id" - date <- param "date" - curr <- param "currency" - amount <- param "amount" - sUrl <- param "siteurl" - orderKey <- param "orderkey" - res <- liftAndCatchIO $ run (findWooToken $ Just (read oid)) + oid <- queryParam "ownerid" + t <- queryParam "token" + ordId <- queryParam "order_id" + date <- queryParam "date" + curr <- queryParam "currency" + amount <- queryParam "amount" + sUrl <- queryParam "siteurl" + orderKey <- queryParam "orderkey" + res <- liftIO $ run (findWooToken $ Just (read oid)) let c = cast' . Doc =<< res case c of Nothing -> do @@ -995,7 +997,7 @@ routes pipe config = do (E.decodeUtf8With lenientDecode . B64.decodeLenient . C.pack) sUrl == fromMaybe "" (w_url x) then do - zecPriceDb <- liftAndCatchIO (run (findPrice curr)) + zecPriceDb <- liftIO (run (findPrice curr)) let zecPrice = parseZGoPrice =<< zecPriceDb case zecPrice of Nothing -> do @@ -1004,8 +1006,7 @@ routes pipe config = do (object ["message" .= ("Currency not supported" :: String)]) Just zP -> do ownerDb <- - liftAndCatchIO $ - run (findOwnerById (T.pack . show $ w_owner x)) + liftIO $ run (findOwnerById (T.pack . show $ w_owner x)) let owner = cast' . Doc =<< ownerDb case owner of Nothing -> do @@ -1046,7 +1047,7 @@ routes pipe config = do 0 0 0 - newId <- liftAndCatchIO $ run (insertWooOrder newOrder) + newId <- liftIO $ run (insertWooOrder newOrder) status ok200 Web.Scotty.json (object ["order" .= show newId, "token" .= tk]) @@ -1060,8 +1061,8 @@ routes pipe config = do Web.Scotty.json (object ["message" .= ("Incorrect plugin config" :: String)]) get "/checkuser" $ do - sess <- param "session" - user <- liftAndCatchIO $ run (findUser sess) + sess <- formParam "session" + user <- liftIO $ run (findUser sess) case parseUserBson =<< user of Nothing -> status noContent204 Just u -> do @@ -1069,8 +1070,8 @@ routes pipe config = do Web.Scotty.json (object ["validated" .= uvalidated u]) --Get user associated with session get "/api/user" $ do - sess <- param "session" - user <- liftAndCatchIO $ run (findUser sess) + sess <- formParam "session" + user <- liftIO $ run (findUser sess) case user of Nothing -> status noContent204 Just u -> do @@ -1082,13 +1083,14 @@ routes pipe config = do ]) --Validate user, updating record post "/validateuser" $ do - providedPin <- param "pin" - sess <- param "session" + providedPin <- formParam "pin" + sess <- formParam "session" let pinHash = BLK.hash + Nothing [ BA.pack . BS.unpack . C.pack . T.unpack $ providedPin <> sess :: BA.Bytes ] - user <- liftAndCatchIO $ run (findUser sess) + user <- liftIO $ run (findUser sess) case user of Nothing -> status noContent204 --`debug` "No user match" Just u -> do @@ -1102,30 +1104,29 @@ routes pipe config = do (pinHash :: BLK.Digest BLK.DEFAULT_DIGEST_LEN)) if ans then do - liftAndCatchIO $ run (validateUser sess) + liftIO $ run (validateUser sess) status accepted202 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" - session <- param "session" + userId <- captureParam "id" + session <- captureParam "session" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r userId then do - u <- liftAndCatchIO $ run (findUserById userId) + u <- liftIO $ run (findUserById userId) case cast' . Doc =<< u of Nothing -> status badRequest400 Just u' -> if session == usession u' then do - liftAndCatchIO $ run (deleteUser userId) + liftIO $ run (deleteUser userId) status ok200 else status forbidden403 else status badRequest400 --Get current blockheight from Zcash node get "/blockheight" $ do - blockInfo <- - liftAndCatchIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"] + blockInfo <- liftIO $ makeZcashCall nodeUser nodePwd "getblock" ["-1"] let content = getResponseBody blockInfo :: RpcResponse Block if isNothing (err content) then do @@ -1137,12 +1138,12 @@ routes pipe config = do get "/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress]) --Get owner by address get "/api/owner" $ do - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case parseUserBson =<< user of Nothing -> status noContent204 Just u -> do - owner <- liftAndCatchIO $ run (findOwner $ uaddress u) + owner <- liftIO $ run (findOwner $ uaddress u) case cast' . Doc =<< owner of Nothing -> status noContent204 Just o -> do @@ -1153,8 +1154,8 @@ routes pipe config = do , "owner" .= getOwnerSettings o ]) get "/ownerid" $ do - id <- param "id" - owner <- liftAndCatchIO $ run (findOwnerById id) + id <- formParam "id" + owner <- liftIO $ run (findOwnerById id) case owner of Nothing -> status noContent204 Just o -> do @@ -1170,15 +1171,15 @@ routes pipe config = do ]) --Upsert owner to DB post "/api/owner" $ do - s <- param "session" - u <- liftAndCatchIO $ run (findUser s) + s <- formParam "session" + u <- liftIO $ run (findUser s) o <- jsonData now <- liftIO getCurrentTime let q = payload (o :: Payload OwnerData) case parseUserBson =<< u of Nothing -> status internalServerError500 Just u' -> do - liftAndCatchIO $ + liftIO $ run $ upsertOwner $ Owner @@ -1210,8 +1211,8 @@ routes pipe config = do False status accepted202 post "/api/ownersettings" $ do - s <- param "session" - u <- liftAndCatchIO $ run (findUser s) + s <- formParam "session" + u <- liftIO $ run (findUser s) o <- jsonData now <- liftIO getCurrentTime let q = payload (o :: Payload OwnerSettings) @@ -1220,12 +1221,12 @@ routes pipe config = do Just u' -> do if os_address q == uaddress u' then do - liftAndCatchIO $ run $ updateOwnerSettings q + liftIO $ run $ updateOwnerSettings q status accepted202 else status noContent204 post "/api/ownervk" $ do - s <- param "session" - u <- liftAndCatchIO $ run (findUser s) + s <- formParam "session" + u <- liftIO $ run (findUser s) o <- jsonData let q = payload (o :: Payload String) let qRaw = decodeBech32 $ C.pack q @@ -1242,12 +1243,12 @@ routes pipe config = do qBytes (bytes . decodeBech32 . C.pack . T.unpack $ uaddress u') then do - owner <- liftAndCatchIO $ run (findOwner $ uaddress u') + owner <- liftIO $ run (findOwner $ uaddress u') case cast' . Doc =<< owner of Nothing -> status badRequest400 Just o' -> do unless (oviewkey o' /= "") $ do - liftAndCatchIO $ run (upsertViewingKey o' q) + liftIO $ run (upsertViewingKey o' q) status created201 else status forbidden403 else case decodeUfvk (C.pack q) of @@ -1260,14 +1261,12 @@ routes pipe config = do (C.pack q) (C.pack . T.unpack $ uaddress u') then do - owner <- - liftAndCatchIO $ run (findOwner $ uaddress u') + owner <- liftIO $ run (findOwner $ uaddress u') case cast' . Doc =<< owner of Nothing -> status badRequest400 Just o' -> do unless (oviewkey o' /= "") $ do - liftAndCatchIO $ - run (upsertViewingKey o' q) + liftIO $ run (upsertViewingKey o' q) status created201 else status forbidden403 Nothing -> do @@ -1276,27 +1275,24 @@ routes pipe config = do (bytes . decodeBech32 . C.pack . T.unpack $ uaddress u') then do - owner <- - liftAndCatchIO $ run (findOwner $ uaddress u') + owner <- liftIO $ run (findOwner $ uaddress u') case cast' . Doc =<< owner of Nothing -> status badRequest400 Just o' -> do unless (oviewkey o' /= "") $ do - liftAndCatchIO $ - run (upsertViewingKey o' q) + liftIO $ run (upsertViewingKey o' q) status created201 else status forbidden403 --Get items associated with the given address get "/api/items" $ do - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status forbidden403 Just u -> do - items <- liftAndCatchIO $ run (findItems $ uaddress u) - case items of - [] -> status noContent204 - _ -> do + items <- liftIO $ run (findItems $ uaddress u) + if not (null items) + then do let pItems = map (cast' . Doc) items :: [Maybe Item] status ok200 Web.Scotty.json @@ -1304,41 +1300,42 @@ routes pipe config = do [ "message" .= ("Items found!" :: String) , "items" .= toJSON pItems ]) + else status noContent204 --Upsert item post "/api/item" $ do i <- jsonData - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status forbidden403 Just u -> do let q = payload (i :: Payload Item) if uaddress u == iowner q then do - _ <- liftAndCatchIO $ run (upsertItem q) + _ <- liftIO $ run (upsertItem q) status created201 else status forbidden403 --Delete item Web.Scotty.delete "/api/item/:id" $ do - session <- param "session" - oId <- param "id" - u' <- liftAndCatchIO $ checkUser run session + session <- formParam "session" + oId <- captureParam "id" + u' <- liftIO $ checkUser run session case u' of Nothing -> status forbidden403 Just u -> do - i <- liftAndCatchIO $ run (findItemById oId) + i <- liftIO $ run (findItemById oId) case cast' . Doc =<< i of Nothing -> status badRequest400 Just i' -> do if iowner i' == uaddress u then do - liftAndCatchIO $ run (deleteItem oId) + liftIO $ run (deleteItem oId) status ok200 else status forbidden403 --Get price for Zcash get "/price" $ do - curr <- param "currency" - pr <- liftAndCatchIO $ run (findPrice curr) + curr <- formParam "currency" + pr <- liftIO $ run (findPrice curr) case parseZGoPrice =<< pr of Nothing -> do status noContent204 @@ -1347,15 +1344,15 @@ routes pipe config = do (object ["message" .= ("Price found!" :: String), "price" .= toJSON p]) --Get all closed orders for the address get "/api/allorders" $ do - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - myOrders <- liftAndCatchIO $ run (findAllOrders $ uaddress u) - case myOrders of - [] -> status noContent204 - _ -> do + myOrders <- liftIO $ run (findAllOrders $ uaddress u) + if null myOrders + then status noContent204 + else do let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder] status ok200 Web.Scotty.json @@ -1365,18 +1362,18 @@ routes pipe config = do ]) --Get order by id for receipts get "/order/:id" $ do - oId <- param "id" - token <- param "token" + oId <- captureParam "id" + token <- formParam "token" let r = mkRegex "^[a-f0-9]{24}$" if matchTest r oId then do - myOrder <- liftAndCatchIO $ run (findOrderById oId) + myOrder <- liftIO $ run (findOrderById oId) case cast' . Doc =<< myOrder of Nothing -> status noContent204 Just pOrder -> do if qtoken pOrder == token then do - shop <- liftAndCatchIO $ run (findOwner $ qaddress pOrder) + shop <- liftIO $ run (findOwner $ qaddress pOrder) case cast' . Doc =<< shop of Nothing -> status badRequest400 Just s -> do @@ -1391,8 +1388,8 @@ routes pipe config = do else status badRequest400 --Get order by session get "/api/order" $ do - sess <- param "session" - myOrder <- liftAndCatchIO $ run (findOrder sess) + sess <- formParam "session" + myOrder <- liftIO $ run (findOrder sess) case myOrder of Nothing -> status noContent204 Just o -> do @@ -1412,7 +1409,7 @@ routes pipe config = do {-let q = payload (newOrder :: Payload ZGoOrder)-} {-_ <- liftIO $ run (upsertXeroOrder q)-} {-myOrder <--} - {-liftAndCatchIO $-} + {-liftIO $-} {-run (findXeroOrder (qaddress q) (qexternalInvoice q) (qshortCode q))-} {-case myOrder of-} {-Nothing -> status noContent204-} @@ -1431,12 +1428,12 @@ routes pipe config = do post "/api/order" $ do newOrder <- jsonData let q = payload (newOrder :: Payload ZGoOrder) - session <- param "session" - user <- liftAndCatchIO $ run (findUser session) + session <- formParam "session" + user <- liftIO $ run (findUser session) case cast' . Doc =<< user of Nothing -> status unauthorized401 Just u -> do - owner <- liftAndCatchIO $ run $ findOwner (uaddress u) + owner <- liftIO $ run $ findOwner (uaddress u) case cast' . Doc =<< owner of Nothing -> status badRequest400 Just o -> do @@ -1448,8 +1445,7 @@ routes pipe config = do if ovat o then ovatValue o else 0 - dbOrder <- - liftAndCatchIO $ run (findOrderById $ maybe "0" show (q_id q)) + dbOrder <- liftIO $ run (findOrderById $ maybe "0" show (q_id q)) case cast' . Doc =<< dbOrder of Nothing -> do if uaddress u == qaddress q @@ -1458,7 +1454,7 @@ routes pipe config = do then do t <- liftIO generateToken _ <- - liftAndCatchIO $ + liftIO $ run (upsertOrder (setOrderToken (T.pack t) q) @@ -1467,7 +1463,7 @@ routes pipe config = do status created201 else do _ <- - liftAndCatchIO $ + liftIO $ access pipe master @@ -1484,7 +1480,7 @@ routes pipe config = do then do t <- liftIO generateToken _ <- - liftAndCatchIO $ + liftIO $ run (upsertOrder (setOrderToken (T.pack t) q) @@ -1493,7 +1489,7 @@ routes pipe config = do status created201 else do _ <- - liftAndCatchIO $ + liftIO $ access pipe master @@ -1504,62 +1500,62 @@ routes pipe config = do else status forbidden403 --Delete order Web.Scotty.delete "/api/order/:id" $ do - oId <- param "id" - session <- param "session" - o <- liftAndCatchIO $ run (findOrderById oId) + oId <- captureParam "id" + session <- formParam "session" + o <- liftIO $ run (findOrderById oId) case cast' . Doc =<< o of Nothing -> status badRequest400 Just order -> do if qsession order == session then do - liftAndCatchIO $ run (deleteOrder oId) + liftIO $ run (deleteOrder oId) status ok200 else status forbidden403 -- Get language for component get "/getmainlang" $ do - lang <- param "lang" - txtPack' <- liftAndCatchIO $ run (findLangComponent lang "main") + lang <- queryParam "lang" + txtPack' <- liftIO $ run (findLangComponent lang "main") case cast' . Doc =<< txtPack' of Nothing -> status noContent204 Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/getscanlang" $ do - lang <- param "lang" - txtPack' <- liftAndCatchIO $ run (findLangComponent lang "scan") + lang <- queryParam "lang" + txtPack' <- liftIO $ run (findLangComponent lang "scan") case cast' . Doc =<< txtPack' of Nothing -> status noContent204 Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/getloginlang" $ do - lang <- param "lang" - txtPack' <- liftAndCatchIO $ run (findLangComponent lang "login") + lang <- queryParam "lang" + txtPack' <- liftIO $ run (findLangComponent lang "login") case cast' . Doc =<< txtPack' of Nothing -> status noContent204 Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/getinvoicelang" $ do - lang <- param "lang" - txtPack' <- liftAndCatchIO $ run (findLangComponent lang "invoice") + lang <- queryParam "lang" + txtPack' <- liftIO $ run (findLangComponent lang "invoice") case cast' . Doc =<< txtPack' of Nothing -> status noContent204 Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/getpmtservicelang" $ do - lang <- param "lang" - txtPack' <- liftAndCatchIO $ run (findLangComponent lang "pmtservice") + lang <- queryParam "lang" + txtPack' <- liftIO $ run (findLangComponent lang "pmtservice") case cast' . Doc =<< txtPack' of Nothing -> status noContent204 Just textPack -> do status ok200 Web.Scotty.json $ toJSON (textPack :: LangComponent) get "/api/getlang" $ do - component <- param "component" - lang <- param "lang" - txtPack' <- liftAndCatchIO $ run (findLangComponent lang component) + component <- queryParam "component" + lang <- queryParam "lang" + txtPack' <- liftIO $ run (findLangComponent lang component) let txtPack = cast' . Doc =<< txtPack' case txtPack of Nothing -> status noContent204 @@ -1569,7 +1565,7 @@ routes pipe config = do {-post "/api/setlang" $ do-} {-langComp <- jsonData-} {-_ <--} - {-liftAndCatchIO $-} + {-liftIO $-} {-mapM (run . loadLangComponent) (langComp :: [LangComponent])-} {-status created201-} {-(MonadIO m, FromJSON a)-} @@ -2007,17 +2003,17 @@ scanTxNative config pipe = do filterTx t = not (null (maybe [] rt_shieldedOutputs t)) || not (null (maybe [] rt_orchardActions t)) - extractTxs :: Maybe BlockResponse -> [T.Text] + extractTxs :: Maybe BlockResponse -> [HexString] extractTxs = maybe [] bl_txs getTxData :: - BS.ByteString -> BS.ByteString -> T.Text -> IO (Maybe RawTxResponse) + BS.ByteString -> BS.ByteString -> HexString -> IO (Maybe RawTxResponse) getTxData nodeUser nodePwd txid = do txInfo <- makeZcashCall nodeUser nodePwd "getrawtransaction" - [Data.Aeson.String txid, Number $ SC.scientific 1 0] + [Data.Aeson.String (toText txid), Number $ SC.scientific 1 0] let content = getResponseBody txInfo :: RpcResponse RawTxResponse if isNothing (err content) then return $ result content @@ -2075,7 +2071,7 @@ scanTxNative config pipe = do (E.decodeUtf8Lenient $ a_memo n) recordPayment :: Pipe -> T.Text -> T.Text -> ZcashTx -> IO () recordPayment p dbName z x = do - let zM = runParser pZGoMemo (T.unpack . ztxid $ x) (zmemo x) + let zM = runParser pZGoMemo (T.unpack . toText . ztxid $ x) (zmemo x) case zM of Right m -> do case m_orderId m of @@ -2165,14 +2161,14 @@ instance Val BlockResponse where h <- B.lookup "height" d t <- B.lookup "time" d txs <- B.lookup "tx" d - Just (BlockResponse c h t txs) + Just (BlockResponse c h t (map fromText txs)) cast' _ = Nothing val (BlockResponse c h t txs) = Doc [ "confirmations" =: c , "height" =: h , "time" =: t - , "tx" =: txs + , "tx" =: (map toText txs) , "network" =: ("mainnet" :: String) ] diff --git a/zgo-backend.cabal b/zgo-backend.cabal index dc289d8..91293f4 100644 --- a/zgo-backend.cabal +++ b/zgo-backend.cabal @@ -1,11 +1,11 @@ -cabal-version: 1.12 +cabal-version: 3.0 -- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: zgo-backend -version: 1.8.1 +version: 1.9.0 synopsis: Haskell Back-end for the ZGo point-of-sale application description: Please see the README at category: Web @@ -20,10 +20,6 @@ extra-source-files: CHANGELOG.md zgo.cfg -source-repository head - type: git - location: https://git.vergara.tech/Vergara_Tech/zgo-backend - library exposed-modules: Config @@ -37,8 +33,6 @@ library Xero ZGoBackend ZGoTx - other-modules: - Paths_zgo_backend hs-source-dirs: src build-depends: @@ -83,13 +77,11 @@ library executable zgo-backend-exe main-is: Server.hs - other-modules: - Tasks - TokenRefresh - Paths_zgo_backend hs-source-dirs: app ghc-options: -main-is Server -threaded -rtsopts -with-rtsopts=-N -Wall + pkgconfig-depends: + rustzcash_wrapper build-depends: aeson , base @@ -98,7 +90,7 @@ executable zgo-backend-exe , http-conduit , http-types , megaparsec - , mongoDB + , mongoDB >=2.7.1.4 , scotty , securemem , text @@ -111,13 +103,11 @@ executable zgo-backend-exe executable zgo-tasks main-is: Tasks.hs - other-modules: - Server - TokenRefresh - Paths_zgo_backend hs-source-dirs: app ghc-options: -main-is Tasks -threaded -rtsopts -with-rtsopts=-N -Wall + pkgconfig-depends: + rustzcash_wrapper build-depends: base , megaparsec @@ -131,13 +121,11 @@ executable zgo-tasks executable zgo-token-refresh main-is: TokenRefresh.hs - other-modules: - Server - Tasks - Paths_zgo_backend hs-source-dirs: app ghc-options: -main-is TokenRefresh -threaded -rtsopts -with-rtsopts=-N -Wall + pkgconfig-depends: + rustzcash_wrapper build-depends: aeson , base @@ -160,11 +148,11 @@ executable zgo-token-refresh test-suite zgo-backend-test type: exitcode-stdio-1.0 main-is: Spec.hs - other-modules: - Paths_zgo_backend hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N -main-is Spec + pkgconfig-depends: + rustzcash_wrapper build-depends: QuickCheck , aeson