Implement config file

app/Main.hs

@@ -2,33 +2,38 @@
 
 module Main where
 
-import Control.Concurrent (forkIO, threadDelay)
+import Control.Concurrent (forkIO)
+import Data.Configurator
 import Data.SecureMem
-import qualified Data.Text as T
 import Database.MongoDB
+import Network.Wai.Handler.WarpTLS (tlsSettings)
 import ZGoBackend
 
-passkey :: SecureMem
-passkey = secureMemFromByteString "superSecret"
-
-nodeAddress :: T.Text
-nodeAddress =
-  "zs1xnpqd2tae9d95f8fhe4l0q7j44a5vf993m0pcnnvr56uqr4lgqlamesk5v4c5rhtvywc6lvlduy"
-
-dbUser :: T.Text
-dbUser = "zgo"
-
-dbPassword :: T.Text
-dbPassword = "zcashrules"
-
 main :: IO ()
 main = do
+  putStrLn "Reading config..."
+  config <- load ["zgo.cfg"]
+  dbName <- require config "dbName"
+  dbUser <- require config "dbUser"
+  dbPassword <- require config "dbPassword"
+  nodeAddress <- require config "nodeAddress"
+  passkey <- secureMemFromByteString <$> require config "passkey"
+  port <- require config "port"
+  useTls <- require config "tls"
+  cert <- require config "certificate"
+  key <- require config "key"
+  let myTlsSettings =
+        if useTls
+          then Just $ tlsSettings cert key
+          else Nothing
   putStrLn "Starting Server..."
   pipe <- connect $ host "127.0.0.1"
-  j <- access pipe master "zgo" (auth dbUser dbPassword)
-  _ <- forkIO (setInterval 60 (checkZcashPrices pipe "zgo"))
-  _ <- forkIO (setInterval 75 (scanZcash nodeAddress pipe "zgo"))
+  j <- access pipe master dbName (auth dbUser dbPassword)
   if j
     then putStrLn "Connected to MongoDB!"
     else fail "MongoDB connection failed!"
-  app pipe "zgo" passkey nodeAddress
+  _ <- forkIO (setInterval 60 (checkZcashPrices pipe dbName))
+  _ <- 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

package.yaml

@@ -46,6 +46,7 @@ library:
   - random
   - vector
   - wai-cors
+  - warp-tls
 
 executables:
   zgo-backend-exe:
@@ -69,6 +70,8 @@ executables:
     - http-conduit
     - time
     - bytestring
+    - configurator
+    - warp-tls
 
 tests:
   zgo-backend-test:

src/Item.hs

@@ -90,7 +90,10 @@ upsertItem :: Item -> Action IO ()
 upsertItem i = do
   let item = val i
   case item of
-    Doc d -> upsert (select ["_id" =: i_id i] "items") d
+    Doc d ->
+      if isJust (i_id i)
+        then upsert (select ["_id" =: i_id i] "items") d
+        else insert_ "items" d
     _ -> return ()
 
 deleteItem :: String -> Action IO ()

src/Order.hs

@@ -130,48 +130,30 @@ instance Val ZGoOrder where
 -- Type to represent an order line item
 data LineItem =
   LineItem
-    { l_id :: Maybe ObjectId
-    , lqty :: Double
+    { lqty :: Double
     , lname :: T.Text
     , lcost :: Double
     }
   deriving (Eq, Show)
 
 instance ToJSON LineItem where
-  toJSON (LineItem i q n c) =
-    case i of
-      Just oid ->
-        object ["_id" .= show oid, "qty" .= q, "name" .= n, "cost" .= c]
-      Nothing ->
-        object ["_id" .= ("" :: String), "qty" .= q, "name" .= n, "cost" .= c]
+  toJSON (LineItem q n c) = object ["qty" .= q, "name" .= n, "cost" .= c]
 
 instance FromJSON LineItem where
   parseJSON =
     withObject "LineItem" $ \obj -> do
-      i <- obj .: "_id"
       q <- obj .: "qty"
       n <- obj .: "name"
       c <- obj .: "cost"
-      pure $
-        LineItem
-          (if not (null i)
-             then Just (read i)
-             else Nothing)
-          q
-          n
-          c
+      pure $ LineItem q n c
 
 instance Val LineItem where
-  val (LineItem i q n c) =
-    case i of
-      Just oid -> Doc ["_id" =: oid, "qty" =: q, "name" =: n, "cost" =: c]
-      Nothing -> Doc ["qty" =: q, "name" =: n, "cost" =: c]
+  val (LineItem q n c) = Doc ["qty" =: q, "name" =: n, "cost" =: c]
   cast' (Doc d) = do
-    i <- B.lookup "_id" d
     q <- B.lookup "qty" d
     n <- B.lookup "name" d
     c <- B.lookup "cost" d
-    Just (LineItem i q n c)
+    Just (LineItem q n c)
   cast' _ = Nothing
 
 -- Database actions
@@ -179,11 +161,14 @@ upsertOrder :: ZGoOrder -> Action IO ()
 upsertOrder o = do
   let order = val o
   case order of
-    Doc d -> upsert (select ["_id" =: q_id o] "orders") d
+    Doc d ->
+      if isJust (q_id o)
+        then upsert (select ["_id" =: q_id o] "orders") d
+        else insert_ "orders" d
     _ -> return ()
 
 findOrder :: T.Text -> Action IO (Maybe Document)
-findOrder s = findOne (select ["session" =: s] "orders")
+findOrder s = findOne (select ["session" =: s, "closed" =: False] "orders")
 
 findOrderById :: String -> Action IO (Maybe Document)
 findOrderById i = findOne (select ["_id" =: (read i :: B.ObjectId)] "orders")

src/ZGoBackend.hs

@@ -29,6 +29,7 @@ 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,8 +315,15 @@ upsertZGoTx coll t = do
   upsert (select ["txid" =: txid t] coll) (encodeZGoTxBson t)
 
 -- | Main API function
-app :: Pipe -> T.Text -> SecureMem -> T.Text -> IO ()
-app pipe db passkey nodeAddress = do
+app ::
+     Pipe
+  -> T.Text
+  -> SecureMem
+  -> T.Text
+  -> Integer
+  -> Maybe TLSSettings
+  -> IO ()
+app pipe db passkey nodeAddress port tls = do
   let run = access pipe master db
   scotty 3000 $ do
     middleware $
@@ -372,9 +380,7 @@ app pipe db passkey nodeAddress = do
                 then do
                   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: " ++ providedPin ++ " " ++ T.unpack (upin pUser))
     --Delete user
     Web.Scotty.delete "/api/user/:id" $ do
       userId <- param "id"
@@ -443,7 +449,8 @@ app pipe db passkey nodeAddress = do
     --Upsert item
     post "/api/item" $ do
       i <- jsonData
-      _ <- liftIO $ run (upsertItem i)
+      let q = payload (i :: Payload Item)
+      _ <- liftIO $ run (upsertItem q)
       status created201
     --Delete item
     Web.Scotty.delete "/api/item/:id" $ do
@@ -515,7 +522,8 @@ app pipe db passkey nodeAddress = do
     --Upsert order
     post "/api/order" $ do
       newOrder <- jsonData
-      _ <- liftIO $ run (upsertOrder newOrder)
+      let q = payload (newOrder :: Payload ZGoOrder)
+      _ <- liftIO $ run (upsertOrder q)
       status created201
     --Delete order
     Web.Scotty.delete "/api/order/:id" $ do

zgo-backend.cabal

@@ -58,6 +58,7 @@ library
     , vector
     , wai-cors
     , wai-extra
+    , warp-tls
   default-language: Haskell2010
 
 executable zgo-backend-exe
@@ -71,6 +72,7 @@ executable zgo-backend-exe
       aeson
     , base
     , bytestring
+    , configurator
     , http-conduit
     , http-types
     , mongoDB
@@ -79,6 +81,7 @@ executable zgo-backend-exe
     , text
     , time
     , wai-extra
+    , warp-tls
     , zgo-backend
   default-language: Haskell2010
 

zgo.cfg

@@ -0,0 +1,9 @@
+passkey = "superSecret"
+nodeAddress = "zs1xnpqd2tae9d95f8fhe4l0q7j44a5vf993m0pcnnvr56uqr4lgqlamesk5v4c5rhtvywc6lvlduy"
+dbName = "zgo"
+dbUser = "zgo"
+dbPassword = "zcashrules"
+port = 3000
+tls = false
+cert = "/path/to/cert.pem"
+key = "/path/to/key.pem"