Add initial exchange

1 files changed, 67 insertions, 0 deletions

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 ()
+