From 3574beab58abc9557ab91efb70d082d25c85806d Mon Sep 17 00:00:00 2001
From: Rene Vergara <rene@vergara.network>
Date: Thu, 19 May 2022 09:52:17 -0500
Subject: [PATCH] Implement TLS for API server

---
 app/Main.hs       |  11 +-
 package.yaml      |   1 +
 src/ZGoBackend.hs | 351 ++++++++++++++++++++++------------------------
 zgo-backend.cabal |   1 +
 zgo.cfg           |   2 +-
 5 files changed, 182 insertions(+), 184 deletions(-)

diff --git a/app/Main.hs b/app/Main.hs
index ca9d0fd..e7ede57 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -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
diff --git a/package.yaml b/package.yaml
index cc0c924..6341f22 100644
--- a/package.yaml
+++ b/package.yaml
@@ -72,6 +72,7 @@ executables:
     - bytestring
     - configurator
     - warp-tls
+    - warp
 
 tests:
   zgo-backend-test:
diff --git a/src/ZGoBackend.hs b/src/ZGoBackend.hs
index 8678520..08600e4 100644
--- a/src/ZGoBackend.hs
+++ b/src/ZGoBackend.hs
@@ -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 ::
diff --git a/zgo-backend.cabal b/zgo-backend.cabal
index 9e3a3da..3f2f324 100644
--- a/zgo-backend.cabal
+++ b/zgo-backend.cabal
@@ -81,6 +81,7 @@ executable zgo-backend-exe
     , text
     , time
     , wai-extra
+    , warp
     , warp-tls
     , zgo-backend
   default-language: Haskell2010
diff --git a/zgo.cfg b/zgo.cfg
index 028e374..adbe4dc 100644
--- a/zgo.cfg
+++ b/zgo.cfg
@@ -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"