diff --git a/.gitignore b/.gitignore index c368d45..e909f1e 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ .stack-work/ -*~ \ No newline at end of file +dist-newstyle/ +*~ diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..b77a9e5 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,4 @@ +[submodule "zcash-haskell"] + path = zcash-haskell + url = https://git.vergara.tech/Vergara_Tech/zcash-haskell + branch = milestone2 diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..836a722 --- /dev/null +++ b/cabal.project @@ -0,0 +1,16 @@ +packages: + ./*.cabal + zcash-haskell/zcash-haskell.cabal + +with-compiler: ghc-9.6.5 + +source-repository-package + type: git + location: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git + tag: 39d8da7b11a80269454c2f134a5c834e0f3cb9a7 + +source-repository-package + type: git + location: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git + tag: 335e804454cd30da2c526457be37e477f71e4665 + diff --git a/package.yaml b/package.yaml deleted file mode 100644 index 6f830c4..0000000 --- a/package.yaml +++ /dev/null @@ -1,167 +0,0 @@ -name: zgo-backend -version: 1.8.1 -git: "https://git.vergara.tech/Vergara_Tech/zgo-backend" -license: MIT -author: "Rene Vergara" -maintainer: "rene@vergara.network" -copyright: "2022-2024 Vergara Technologies LLC" - -extra-source-files: -- README.md -- CHANGELOG.md -- zgo.cfg - -# Metadata used when publishing your package -synopsis: Haskell Back-end for the ZGo point-of-sale application -category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README at - -dependencies: -- base >= 4.7 && < 5 - -library: - source-dirs: src - dependencies: - - mongoDB - - time - - text - - unordered-containers - - bson - - aeson - - QuickCheck - - quickcheck-instances - - scotty - - http-conduit - - wai-extra - - http-types - - time - - securemem - - bytestring - - regex-base - - regex-compat - - array - - random - - vector - - wai-cors - - warp-tls - - hexstring - - configurator - - scientific - - jwt - - containers - - base64-bytestring - - wai - - blake3 - - memory - - ghc-prim - - network - - crypto-rng - - megaparsec - - uuid - - zcash-haskell - -executables: - zgo-backend-exe: - main: Server.hs - source-dirs: app - ghc-options: - - -main-is Server - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall - dependencies: - - zgo-backend - - base - - scotty - - wai-extra - - securemem - - text - - aeson - - mongoDB - - http-types - - http-conduit - - time - - bytestring - - configurator - - warp-tls - - warp - - megaparsec - zgo-token-refresh: - main: TokenRefresh.hs - source-dirs: app - ghc-options: - - -main-is TokenRefresh - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall - dependencies: - - base - - zgo-backend - - base - - scotty - - wai-extra - - securemem - - text - - aeson - - mongoDB - - http-types - - http-conduit - - time - - bytestring - - configurator - - warp-tls - - warp - - megaparsec - zgo-tasks: - main: Tasks.hs - source-dirs: app - ghc-options: - - -main-is Tasks - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -Wall - dependencies: - - base - - mongoDB - - zgo-backend - - scotty - - warp-tls - - warp - - time - - megaparsec - -tests: - zgo-backend-test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -main-is Spec - dependencies: - - zgo-backend - - hspec - - QuickCheck - - text - - aeson - - http-conduit - - http-types - - hspec-expectations-json - - bytestring - - mongoDB - - hspec-wai - - securemem - - time - - configurator - - scotty - - megaparsec - - uuid - - zcash-haskell diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs index a5a0bac..ef88e2e 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 <- queryParam "code" + session <- queryParam "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 <- queryParam "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 <- queryParam "session" + c <- queryParam "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 <- queryParam "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 <- queryParam "ownerid" + session <- queryParam "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 <- queryParam "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 <- queryParam "session" + user <- liftIO $ run (findUser sess) case user of Nothing -> status noContent204 Just u -> do @@ -1082,19 +1083,20 @@ routes pipe config = do ]) --Validate user, updating record post "/validateuser" $ do - providedPin <- param "pin" - sess <- param "session" + providedPin <- queryParam "pin" + sess <- queryParam "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" + Nothing -> status noContent204 `debug` "No user match" Just u -> do let parsedUser = parseUserBson u case parsedUser of - Nothing -> status noContent204 --`debug` "Couldn't parse user" + Nothing -> status noContent204 `debug` "Couldn't parse user" Just pUser -> do let ans = upin pUser == @@ -1102,30 +1104,31 @@ 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)) + else status noContent204 `debug` + ("Pins didn't match: " ++ + T.unpack providedPin ++ " " ++ T.unpack (upin pUser)) --Delete user Web.Scotty.delete "/api/user/:id" $ do - userId <- param "id" - session <- param "session" + userId <- captureParam "id" + session <- queryParam "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 +1140,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 <- queryParam "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 +1156,8 @@ routes pipe config = do , "owner" .= getOwnerSettings o ]) get "/ownerid" $ do - id <- param "id" - owner <- liftAndCatchIO $ run (findOwnerById id) + id <- queryParam "id" + owner <- liftIO $ run (findOwnerById id) case owner of Nothing -> status noContent204 Just o -> do @@ -1170,15 +1173,15 @@ routes pipe config = do ]) --Upsert owner to DB post "/api/owner" $ do - s <- param "session" - u <- liftAndCatchIO $ run (findUser s) + s <- queryParam "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 +1213,8 @@ routes pipe config = do False status accepted202 post "/api/ownersettings" $ do - s <- param "session" - u <- liftAndCatchIO $ run (findUser s) + s <- queryParam "session" + u <- liftIO $ run (findUser s) o <- jsonData now <- liftIO getCurrentTime let q = payload (o :: Payload OwnerSettings) @@ -1220,12 +1223,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 <- queryParam "session" + u <- liftIO $ run (findUser s) o <- jsonData let q = payload (o :: Payload String) let qRaw = decodeBech32 $ C.pack q @@ -1242,12 +1245,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 +1263,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 +1277,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 <- queryParam "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 +1302,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 <- queryParam "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 <- queryParam "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 <- queryParam "currency" + pr <- liftIO $ run (findPrice curr) case parseZGoPrice =<< pr of Nothing -> do status noContent204 @@ -1347,15 +1346,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 <- queryParam "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 +1364,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 <- queryParam "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 +1390,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 <- queryParam "session" + myOrder <- liftIO $ run (findOrder sess) case myOrder of Nothing -> status noContent204 Just o -> do @@ -1412,7 +1411,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 +1430,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 <- queryParam "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 +1447,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 +1456,7 @@ routes pipe config = do then do t <- liftIO generateToken _ <- - liftAndCatchIO $ + liftIO $ run (upsertOrder (setOrderToken (T.pack t) q) @@ -1467,7 +1465,7 @@ routes pipe config = do status created201 else do _ <- - liftAndCatchIO $ + liftIO $ access pipe master @@ -1484,7 +1482,7 @@ routes pipe config = do then do t <- liftIO generateToken _ <- - liftAndCatchIO $ + liftIO $ run (upsertOrder (setOrderToken (T.pack t) q) @@ -1493,7 +1491,7 @@ routes pipe config = do status created201 else do _ <- - liftAndCatchIO $ + liftIO $ access pipe master @@ -1504,62 +1502,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 <- queryParam "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 +1567,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 +2005,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 +2073,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 +2163,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/stack.yaml b/stack.yaml deleted file mode 100644 index 3cd01e4..0000000 --- a/stack.yaml +++ /dev/null @@ -1,86 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-21.22 - #url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/4.yaml - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -# extra-deps: [] -extra-deps: - #- git: https://github.com/reach-sh/haskell-hexstring.git - #commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - - git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git - commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae - - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git - commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 - - git: https://github.com/well-typed/borsh.git - commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 - - git: https://git.vergara.tech/Vergara_Tech/mongodb.git - commit: 63bba3a6d30e5fd73c71fd7da752b2647d94f58e - # - network-2.8.0.1@sha256:a79f3cf88b2623d5f2e7a8fc7962055f6858d6beb6d13c2aef43c20a5060cf28,3034 - - aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359 - - vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 - - generically-0.1.1 - - vector-algorithms-0.9.0.1 - - blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 - - crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565 -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.7" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock deleted file mode 100644 index 015116c..0000000 --- a/stack.yaml.lock +++ /dev/null @@ -1,109 +0,0 @@ -# This file was autogenerated by Stack. -# You should not edit this file by hand. -# For more information, please see the documentation at: -# https://docs.haskellstack.org/en/stable/lock_files - -packages: -- completed: - commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git - name: hexstring - pantry-tree: - sha256: 9ecf67856f59dfb382b283eceb42e4fc1865935d1a7e59111556ed381c6a2ffd - size: 687 - version: 0.11.1 - original: - commit: 085c16fb21b9f856a435a3faab980e7e0b319341 - git: https://git.vergara.tech/Vergara_Tech/haskell-hexstring.git -- completed: - commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git - name: zcash-haskell - pantry-tree: - sha256: 000770930e5d50596b82b38984d6e8ab94fd5345c7fcf3cc21682ef8e6348746 - size: 1365 - version: 0.3.0 - original: - commit: dce171d83043fae0e5c771ff743d31c4ec19c1ae - git: https://git.vergara.tech/Vergara_Tech/zcash-haskell.git -- completed: - commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git - name: foreign-rust - pantry-tree: - sha256: be2f6fc0fab58a90fec657bdb6bd0ccf0810c7dccfe95c78b85e174fae227e42 - size: 2315 - version: 0.1.0 - original: - commit: 787c2e813eb3a5d16c375d4b37dfefbd2adcdf05 - git: https://git.vergara.tech/Vergara_Tech/haskell-foreign-rust.git -- completed: - commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 - git: https://github.com/well-typed/borsh.git - name: borsh - pantry-tree: - sha256: 8335925f495a5a653fcb74b6b8bb18cd0b6b7fe7099a1686108704e6ab82f47b - size: 2268 - version: 0.3.0 - original: - commit: d2fcfa159e0a844b1ec5e8ed3e232d4b380fa831 - git: https://github.com/well-typed/borsh.git -- completed: - commit: 63bba3a6d30e5fd73c71fd7da752b2647d94f58e - git: https://git.vergara.tech/Vergara_Tech/mongodb.git - name: mongoDB - pantry-tree: - sha256: 63af9dc2612131fb5d1ea9d75b7055d5d0b28ca443149be1fb47c22bf204128f - size: 2297 - version: 2.7.1.2 - original: - commit: 63bba3a6d30e5fd73c71fd7da752b2647d94f58e - git: https://git.vergara.tech/Vergara_Tech/mongodb.git -- completed: - hackage: aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359 - pantry-tree: - sha256: 58d33beedd6e0ff79920c636d8a4295deb684b6e97c9b1ca94d3c780958d6302 - size: 82465 - original: - hackage: aeson-2.1.2.1@sha256:5b8d62a60963a925c4d123a46e42a8e235a32188522c9f119f64ac228c2612a7,6359 -- completed: - hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 - pantry-tree: - sha256: d2461d28022c8c0a91da08b579b1bff478f617102d2f5ef596cc5b28d14b8b6a - size: 4092 - original: - hackage: vector-0.13.0.0@sha256:fa5cac81a17a5af388716792e8b99c24b3b66770086756d0d8b23f8272a0244c,9112 -- completed: - hackage: generically-0.1.1@sha256:2b9b5efb6eea2fb65377565d53d85b0ccc5b37404fba4bef1d60277caa877e5e,1155 - pantry-tree: - sha256: 98a8fe89d516d3752a9cc0af22cfa652f098cc6613da080762b63aa1d596e56d - size: 233 - original: - hackage: generically-0.1.1 -- completed: - hackage: vector-algorithms-0.9.0.1@sha256:f3e5c6695529a94edf762117cafd91c989cb642ad3f8ca4014dbb13c8f6c2a20,3826 - pantry-tree: - sha256: aef389e57ae6020e5da719bee40aaf6cccf1c4d1e7743a85d30c9d8c25d170a0 - size: 1510 - original: - hackage: vector-algorithms-0.9.0.1 -- completed: - hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 - pantry-tree: - sha256: 0264ef3e7919e7b0d668c4153f6ce0d88e6965626b52d9dfd2cafd70309501d3 - size: 1433 - original: - hackage: blake3-0.2@sha256:d1146b9a51ccfbb0532780778b6d016a614e3d44c05d8c1923dde9a8be869045,2448 -- completed: - hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565 - pantry-tree: - sha256: 1caccafe35d1ae3063f057c31188742a8e794f4f4e4530bab4019c0a514ee54f - size: 455 - original: - hackage: crypto-rng-0.3.0.1@sha256:04f4ae75943ecad8b794950985054130f272d65a588b6b6528f56df0bfedc4dc,1565 -snapshots: -- completed: - sha256: afd5ba64ab602cabc2d3942d3d7e7dd6311bc626dcb415b901eaf576cb62f0ea - size: 640060 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/22.yaml - original: lts-21.22 diff --git a/test/Spec.hs b/test/Spec.hs index 35d60cf..c8fa585 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -28,6 +28,7 @@ import Order import Owner import Payment import System.IO.Unsafe +import Test.HUnit hiding (assert) import Test.Hspec import Test.Hspec.Expectations.Json import Test.Hspec.QuickCheck @@ -36,7 +37,7 @@ import Test.QuickCheck.Gen import Test.QuickCheck.Monadic import Text.Megaparsec import User -import Web.Scotty +import Web.Scotty hiding (getResponseStatus) import WooCommerce import Xero import ZGoBackend @@ -169,7 +170,7 @@ main = do res <- httpLBS req getResponseStatus res `shouldBe` unauthorized401 describe "blockheight endpoint" $ do - it "returns a block number" $ do + xit "returns a block number" $ do req <- testGet "/blockheight" @@ -776,10 +777,10 @@ main = do describe "Database actions" $ do describe "authentication" $ do it "should succeed with good creds" $ \p -> do - r <- liftIO $ access p master "zgo" (auth "zgo" "zcashrules") + r <- liftIO $ access p master "test" (auth "zgo" "zcashrules") r `shouldBe` True it "should fail with bad creds" $ \p -> do - r <- liftIO $ access p master "zgo" (auth "user" "pwd") + r <- liftIO $ access p master "test" (auth "user" "pwd") r `shouldBe` False describe "ZGo Pro sessions" $ do it "find in DB" $ \p -> do @@ -793,21 +794,21 @@ main = do it "should update" $ \p -> do doc <- access p master "test" $ findPrice "usd" case doc of - Nothing -> True `shouldBe` False + Nothing -> assertFailure "couldn't find price" Just d -> do let q = parseZGoPrice d case q of - Nothing -> True `shouldBe` False + Nothing -> assertFailure "couldn't parse price" Just r -> do let t1 = ZGoBackend.timestamp r _ <- checkZcashPrices p "test" doc2 <- access p master "test" $ findPrice "usd" case doc2 of - Nothing -> True `shouldBe` False + Nothing -> assertFailure "couldn't find price" Just d2 -> do let q2 = parseZGoPrice d2 case q2 of - Nothing -> True `shouldBe` False + Nothing -> assertFailure "couldn't parse price" Just r2 -> do let t2 = ZGoBackend.timestamp r2 t2 `shouldSatisfy` (t1 <) @@ -1133,7 +1134,7 @@ testItemAdd i = do openDbConnection :: IO Pipe openDbConnection = do pipe <- connect $ host "127.0.0.1" - access pipe master "zgo" (auth "zgo" "zcashrules") + access pipe master "test" (auth "zgo" "zcashrules") return pipe -- | Close the MongoDB pipe @@ -1156,7 +1157,7 @@ startAPI :: Config -> IO () startAPI config = do putStrLn "Starting test server ..." pipe <- connect $ host $ c_dbHost config - c <- access pipe master "zgo" (auth (c_dbUser config) (c_dbPassword config)) + c <- access pipe master "test" (auth (c_dbUser config) (c_dbPassword config)) let appRoutes = routes pipe config _ <- forkIO (scotty 3000 appRoutes) _ <- diff --git a/zcash-haskell b/zcash-haskell new file mode 160000 index 0000000..90c8a7c --- /dev/null +++ b/zcash-haskell @@ -0,0 +1 @@ +Subproject commit 90c8a7c3028bd6836dea5655221277a25d457653 diff --git a/zgo-backend.cabal b/zgo-backend.cabal index dc289d8..416f405 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 @@ -175,6 +163,7 @@ test-suite zgo-backend-test , hspec-expectations-json , hspec-wai , http-conduit + , HUnit , http-types , megaparsec , mongoDB