Add initial exchange

4 files changed, 109 insertions, 2 deletions

diff --git a/fig-web/fig-web.cabal b/fig-web/fig-web.cabal
index 0b8aa8e..8782593 100644
--- a/fig-web/fig-web.cabal
+++ b/fig-web/fig-web.cabal
@@ -63,6 +63,7 @@ library
     Fig.Web.State
     Fig.Web.DB
     Fig.Web.LDAP
+    Fig.Web.Exchange
 
 executable fig-web
   import: defaults
diff --git a/fig-web/src/Fig/Web.hs b/fig-web/src/Fig/Web.hs
index e200cf6..b08a032 100644
--- a/fig-web/src/Fig/Web.hs
+++ b/fig-web/src/Fig/Web.hs
@@ -31,6 +31,7 @@ import Fig.Web.Auth
 import Fig.Web.State
 import qualified Fig.Web.DB as DB
 import qualified Fig.Web.LDAP as LDAP
+import qualified Fig.Web.Exchange as Exchange
 
 data LiveEvent
   = LiveEventOnline !(Set.Set Text)
@@ -188,6 +189,9 @@ app cfg cmds liveEvents currentlyLive = do
     Sc.get "/api/circle" do
       live <- liftIO $ MVar.readMVar currentlyLive
       Sc.text . Text.L.fromStrict . pretty . SExprList @Void $ SExprString <$> Set.toList live
+    Sc.get "/api/exchange" do
+      listings <- Exchange.getOrders db
+      Sc.json listings
     websocket "/api/circle/events" \conn -> do
       c <- Chan.dupChan liveEvents
       forever do
diff --git a/fig-web/src/Fig/Web/Exchange.hs b/fig-web/src/Fig/Web/Exchange.hs
new file mode 100644
index 0000000..264e73c
--- /dev/null
+++ b/fig-web/src/Fig/Web/Exchange.hs
@@ -0,0 +1,67 @@
+module Fig.Web.Exchange where
+
+import Control.Error.Util (hush)
+
+import qualified Database.Redis as Redis
+
+import Data.Maybe (mapMaybe)
+import qualified Data.Aeson as Aeson
+import qualified Data.Text.Read as Text.R
+import qualified Data.ByteString.Lazy as BS.Lazy
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+
+import Fig.Prelude
+
+adjustUserCurrency :: Text -> Text -> Integer -> Redis.Redis ()
+adjustUserCurrency user cur amt = do
+  let key = "currency:" <> encodeUtf8 user
+  let ecur = encodeUtf8 cur
+  mold <- hush <$> Redis.hget key ecur
+  let old = case mold of
+        Just (Just o) -> case Text.R.decimal $ decodeUtf8 o of
+          Right (num, _) -> num
+          _else -> 0
+        _else -> 0
+  void . Redis.hset key ecur . encodeUtf8 . tshow $ old + amt
+
+data Order = Order
+  { creator :: !Text
+  , wantCur :: !Text
+  , wantAmount :: !Integer
+  , haveCur :: !Text
+  , haveAmount :: !Integer
+  } deriving Generic
+instance Aeson.ToJSON Order
+instance Aeson.FromJSON Order
+
+createOrder :: MonadIO m => Redis.Connection -> Order -> m ByteString
+createOrder c o = liftIO $ Redis.runRedis c do
+  let bs = Aeson.encode o
+  uuid <- liftIO UUID.nextRandom
+  let key = BS.Lazy.toStrict $ UUID.toByteString uuid
+  void $ Redis.hset "orders" key (BS.Lazy.toStrict bs)
+  pure key
+
+getOrders :: MonadIO m => Redis.Connection -> m [Order]
+getOrders c = liftIO $ Redis.runRedis c do
+  Redis.hvals "orders" >>= \case
+    Left _ -> pure []
+    Right orders -> pure $ mapMaybe (Aeson.decode' . BS.Lazy.fromStrict) orders
+
+cancelOrder :: MonadIO m => Redis.Connection -> ByteString -> m ()
+cancelOrder c key = liftIO $ Redis.runRedis c do
+  void $ Redis.hdel "orders" [key]
+
+satisfyOrder :: MonadIO m => Redis.Connection -> ByteString -> Text -> m ()
+satisfyOrder c key buyer = liftIO $ Redis.runRedis c do
+  Redis.hget "orders" key >>= \case
+    Right (Just bs) -> case Aeson.decode' $ BS.Lazy.fromStrict bs of
+      Nothing -> pure ()
+      Just (order :: Order) -> do
+        adjustUserCurrency buyer order.wantCur (-order.wantAmount)
+        adjustUserCurrency order.creator order.wantCur order.wantAmount
+        adjustUserCurrency buyer order.haveCur order.haveAmount
+        adjustUserCurrency order.creator order.haveCur (-order.haveAmount)
+    _else -> pure ()
+        
diff --git a/fig-web/src/Fig/Web/Secure.hs b/fig-web/src/Fig/Web/Secure.hs
index e02d503..cac0376 100644
--- a/fig-web/src/Fig/Web/Secure.hs
+++ b/fig-web/src/Fig/Web/Secure.hs
@@ -19,6 +19,7 @@ import Fig.Utils.SExpr
 import Fig.Bus.Client
 import Fig.Web.Utils
 import qualified Fig.Web.DB as DB
+import qualified Fig.Web.Exchange as Exchange
 
 data LiveEvent
   = LiveEventOnline !(Set.Set Text)
@@ -44,7 +45,7 @@ sexprStr = SExprString . BS.Base64.encodeBase64 . encodeUtf8
 app :: Config -> Commands IO -> IO Wai.Application
 app cfg cmds = do
   log "Connecting to database..."
-  _db <- DB.connect cfg
+  db <- DB.connect cfg
   log "Connected! Secure server active."
   Sc.scottyApp do
     Sc.middleware . Wai.Static.staticPolicy $ mconcat
@@ -64,7 +65,7 @@ app cfg cmds = do
       muser <- Sc.header "Remote-User"
       memail <- Sc.header "Remote-Email"
       case (muser, memail) of
-        (Just user, Just email) -> do
+        (Just user, Just _email) -> do
           name <- Sc.formParam "name"
           input <- Sc.formParamMaybe "input"
           liftIO $ cmds.publish [sexp|(frontend redeem incoming)|]
@@ -78,5 +79,39 @@ app cfg cmds = do
         _else -> do
           Sc.status status401
           Sc.text "you're not logged in buddy"
+    Sc.post "/api/exchange" do
+      Sc.header "Remote-Email" >>= \case
+        Nothing -> do
+          Sc.status status401
+          Sc.text "you're not logged in buddy"
+        Just creator -> do
+          haveCur <- Text.Lazy.toStrict <$> Sc.formParam "haveCur"
+          haveAmount <- Sc.formParam "haveAmount"
+          wantCur <- Text.Lazy.toStrict <$> Sc.formParam "wantCur"
+          wantAmount <- Sc.formParam "wantAmount"
+          key <- Exchange.createOrder db $ Exchange.Order
+            { creator = Text.Lazy.toStrict creator
+            , haveCur = haveCur
+            , haveAmount = haveAmount
+            , wantCur = wantCur
+            , wantAmount = wantAmount
+            }
+          Sc.text . Text.Lazy.fromStrict $ decodeUtf8 key
+    Sc.post "/api/exchange/:key" do
+      Sc.header "Remote-Email" >>= \case
+        Nothing -> do
+          Sc.status status401
+          Sc.text "you're not logged in buddy"
+        Just buyer -> do
+          key <- Sc.pathParam "key"
+          Exchange.satisfyOrder db key $ Text.Lazy.toStrict buyer
+    Sc.delete "/api/exchange/:key" do
+      Sc.header "Remote-Email" >>= \case
+        Nothing -> do
+          Sc.status status401
+          Sc.text "you're not logged in buddy"
+        Just _buyer -> do
+          key <- Sc.pathParam "key"
+          Exchange.cancelOrder db key
     Sc.notFound do
       Sc.text "not found"