Implement TLS for API server

This commit is contained in:
Rene Vergara 2022-05-19 09:52:17 -05:00
parent 0d56026183
commit 3574beab58
Signed by: pitmutt
GPG key ID: 65122AD495A7F5B2
5 changed files with 182 additions and 184 deletions

View file

@ -6,7 +6,9 @@ import Control.Concurrent (forkIO)
import Data.Configurator
import Data.SecureMem
import Database.MongoDB
import Network.Wai.Handler.WarpTLS (tlsSettings)
import Network.Wai.Handler.Warp (defaultSettings, setPort)
import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings)
import Web.Scotty
import ZGoBackend
main :: IO ()
@ -36,4 +38,9 @@ main = do
_ <- forkIO (setInterval 75 (scanZcash nodeAddress pipe dbName))
_ <- forkIO (setInterval 60 (checkPayments pipe dbName))
_ <- forkIO (setInterval 60 (expireOwners pipe dbName))
app pipe dbName passkey nodeAddress port myTlsSettings
let appRoutes = routes pipe dbName passkey nodeAddress
case myTlsSettings of
Nothing -> scotty port appRoutes
Just tls -> do
apiCore <- scottyApp appRoutes
runTLS tls (setPort port defaultSettings) apiCore

View file

@ -72,6 +72,7 @@ executables:
- bytestring
- configurator
- warp-tls
- warp
tests:
zgo-backend-test:

View file

@ -29,7 +29,6 @@ import GHC.Generics
import Item
import Network.HTTP.Simple
import Network.HTTP.Types.Status
import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS)
import Network.Wai.Middleware.Cors
import Network.Wai.Middleware.HttpAuth
import Numeric
@ -314,78 +313,70 @@ upsertZGoTx :: T.Text -> ZGoTx -> Action IO ()
upsertZGoTx coll t = do
upsert (select ["txid" =: txid t] coll) (encodeZGoTxBson t)
-- | Main API function
app ::
Pipe
-> T.Text
-> SecureMem
-> T.Text
-> Integer
-> Maybe TLSSettings
-> IO ()
app pipe db passkey nodeAddress port tls = do
-- | Main API routes
routes :: Pipe -> T.Text -> SecureMem -> T.Text -> ScottyM ()
routes pipe db passkey nodeAddress = do
let run = access pipe master db
scotty 3000 $ do
middleware $
cors $
const $
Just
simpleCorsResourcePolicy
{ corsRequestHeaders = ["Authorization", "Content-Type"]
, corsMethods = "DELETE" : simpleMethods
, corsOrigins = Nothing
}
middleware $
basicAuth
(\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
"ZGo Backend"
middleware $
cors $
const $
Just
simpleCorsResourcePolicy
{ corsRequestHeaders = ["Authorization", "Content-Type"]
, corsMethods = "DELETE" : simpleMethods
, corsOrigins = Nothing
}
middleware $
basicAuth
(\u p -> return $ u == "user" && secureMemFromByteString p == passkey)
"ZGo Backend"
--Get list of countries for UI
get "/api/countries" $ do
countries <- liftIO $ run listCountries
case countries of
[] -> do
status noContent204
_ -> do
Web.Scotty.json
(object
[ "message" .= ("Country data found" :: String)
, "countries" .= toJSON (map parseCountryBson countries)
])
get "/api/countries" $ do
countries <- liftIO $ run listCountries
case countries of
[] -> do
status noContent204
_ -> do
Web.Scotty.json
(object
[ "message" .= ("Country data found" :: String)
, "countries" .= toJSON (map parseCountryBson countries)
])
--Get user associated with session
get "/api/user" $ do
sess <- param "session"
user <- liftIO $ run (findUser sess)
case user of
Nothing -> status noContent204
Just u ->
Web.Scotty.json
(object
[ "message" .= ("User found" :: String)
, "user" .= toJSON (parseUserBson u)
])
get "/api/user" $ do
sess <- param "session"
user <- liftIO $ run (findUser sess)
case user of
Nothing -> status noContent204
Just u ->
Web.Scotty.json
(object
[ "message" .= ("User found" :: String)
, "user" .= toJSON (parseUserBson u)
])
--Validate user, updating record
post "/api/validateuser" $ do
providedPin <- param "pin"
sess <- param "session"
user <- liftIO $ run (findUser sess)
case user of
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"
Just pUser -> do
let ans = upin pUser == T.pack providedPin
if ans
then do
liftIO $ run (validateUser sess)
status accepted202
else status noContent204 --`debug` ("Pins didn't match: " ++ providedPin ++ " " ++ T.unpack (upin pUser))
post "/api/validateuser" $ do
providedPin <- param "pin"
sess <- param "session"
user <- liftIO $ run (findUser sess)
case user of
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"
Just pUser -> do
let ans = upin pUser == T.pack providedPin
if ans
then do
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"
liftIO $ run (deleteUser userId)
status ok200
Web.Scotty.delete "/api/user/:id" $ do
userId <- param "id"
liftIO $ run (deleteUser userId)
status ok200
--Get txs from DB that have less than 10 confirmations
{-get "/api/pending" $ do-}
{-sess <- param "session"-}
@ -400,136 +391,134 @@ app pipe db passkey nodeAddress port tls = do
{-, "txs" .= toJSON (map parseZGoTxBson pending)-}
{-])-}
--Get current blockheight from Zcash node
get "/api/blockheight" $ do
blockInfo <- makeZcashCall "getblock" ["-1"]
Web.Scotty.json (result (getResponseBody blockInfo :: RpcResponse Block))
get "/api/blockheight" $ do
blockInfo <- makeZcashCall "getblock" ["-1"]
Web.Scotty.json (result (getResponseBody blockInfo :: RpcResponse Block))
--Get transactions associated with ZGo node
--get "/api/txs" $ do
--txs <- makeZcashCall "z_listreceivedbyaddress" [nodeAddress]
--Web.Scotty.json (result (getResponseBody txs :: RpcResponse [ZcashTx]))
--Get the ZGo node's shielded address
get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
get "/api/getaddr" $ do Web.Scotty.json (object ["addr" .= nodeAddress])
--Get owner by address
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)
])
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
o <- jsonData
let q = payload (o :: Payload Owner)
_ <- liftIO $ run (upsertOwner q)
status created201
post "/api/owner" $ do
o <- jsonData
let q = payload (o :: Payload Owner)
_ <- liftIO $ run (upsertOwner q)
status created201
--Get items associated with the given address
get "/api/items" $ do
addr <- param "address"
items <- liftIO $ run (findItems addr)
case items of
[] -> status noContent204
_ -> do
let pItems = map (cast' . Doc) items :: [Maybe Item]
status ok200
Web.Scotty.json
(object
[ "message" .= ("Items found!" :: String)
, "items" .= toJSON pItems
])
get "/api/items" $ do
addr <- param "address"
items <- liftIO $ run (findItems addr)
case items of
[] -> status noContent204
_ -> do
let pItems = map (cast' . Doc) items :: [Maybe Item]
status ok200
Web.Scotty.json
(object
["message" .= ("Items found!" :: String), "items" .= toJSON pItems])
--Upsert item
post "/api/item" $ do
i <- jsonData
let q = payload (i :: Payload Item)
_ <- liftIO $ run (upsertItem q)
status created201
post "/api/item" $ do
i <- jsonData
let q = payload (i :: Payload Item)
_ <- liftIO $ run (upsertItem q)
status created201
--Delete item
Web.Scotty.delete "/api/item/:id" $ do
oId <- param "id"
liftIO $ run (deleteItem oId)
status ok200
Web.Scotty.delete "/api/item/:id" $ do
oId <- param "id"
liftIO $ run (deleteItem oId)
status ok200
--Get price for Zcash
get "/api/price" $ do
curr <- param "currency"
pr <- liftIO $ run (findPrice curr)
case pr of
Nothing -> do
status noContent204
get "/api/price" $ do
curr <- param "currency"
pr <- liftIO $ run (findPrice curr)
case pr of
Nothing -> do
status noContent204
--Web.Scotty.json (object ["message" .= ("No price" :: T.Text)])
Just p -> do
Web.Scotty.json
(object
[ "message" .= ("Price found!" :: String)
, "price" .= toJSON (parseZGoPrice p)
])
Just p -> do
Web.Scotty.json
(object
[ "message" .= ("Price found!" :: String)
, "price" .= toJSON (parseZGoPrice p)
])
--Get all closed orders for the address
get "/api/allorders" $ do
addr <- param "address"
myOrders <- liftIO $ run (findAllOrders addr)
case myOrders of
[] -> status noContent204
_ -> do
let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder]
status ok200
Web.Scotty.json
(object
[ "message" .= ("Orders found!" :: String)
, "orders" .= toJSON pOrders
])
get "/api/allorders" $ do
addr <- param "address"
myOrders <- liftIO $ run (findAllOrders addr)
case myOrders of
[] -> status noContent204
_ -> do
let pOrders = map (cast' . Doc) myOrders :: [Maybe ZGoOrder]
status ok200
Web.Scotty.json
(object
[ "message" .= ("Orders found!" :: String)
, "orders" .= toJSON pOrders
])
--Get order by id for receipts
get "/api/order/:id" $ do
oId <- param "id"
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 "/api/order/:id" $ do
oId <- param "id"
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
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)
])
get "/api/order" $ do
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
newOrder <- jsonData
let q = payload (newOrder :: Payload ZGoOrder)
_ <- liftIO $ run (upsertOrder q)
status created201
post "/api/order" $ do
newOrder <- jsonData
let q = payload (newOrder :: Payload ZGoOrder)
_ <- liftIO $ run (upsertOrder q)
status created201
--Delete order
Web.Scotty.delete "/api/order/:id" $ do
oId <- param "id"
liftIO $ run (deleteOrder oId)
status ok200
Web.Scotty.delete "/api/order/:id" $ do
oId <- param "id"
liftIO $ run (deleteOrder oId)
status ok200
-- |Make a Zcash RPC call
makeZcashCall ::

View file

@ -81,6 +81,7 @@ executable zgo-backend-exe
, text
, time
, wai-extra
, warp
, warp-tls
, zgo-backend
default-language: Haskell2010

View file

@ -5,5 +5,5 @@ dbUser = "zgo"
dbPassword = "zcashrules"
port = 3000
tls = false
cert = "/path/to/cert.pem"
certificate = "/path/to/cert.pem"
key = "/path/to/key.pem"