[feat] initial draft of delegate server

delegate-app/HydraAuction/Delegate/Server.hs

@@ -0,0 +1,119 @@
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE RankNTypes #-}
+
+module HydraAuction.Delegate.Server (
+  -- * Delegate server types
+  DelegateServerConfig (..),
+  DelegateServerLog (..),
+  DelegateError (..),
+
+  -- * tracing types
+
+  -- ** tracing transformer
+  TracerT (..),
+  runWithTracer,
+  runWithTracer',
+  mapTracerT,
+  askTracer,
+
+  -- ** tracing type class
+  MonadTracer (..),
+
+  -- ** delegate tracing
+  DelegateTracer,
+
+  -- * wai extras
+  ServerAppT,
+) where
+
+-- Prelude imports
+import Hydra.Prelude (ReaderT (runReaderT), withReaderT)
+import Prelude
+
+-- Haskell imports
+import Control.Tracer (Contravariant (contramap), Tracer, natTracer, traceWith)
+import GHC.Generics (Generic)
+import Prettyprinter (Pretty (pretty), line, viaShow)
+
+-- Cardano imports
+import Hydra.Network (IP, PortNumber)
+
+-- Hydra auction imports
+
+import Control.Monad.RWS
+import HydraAuction.Delegate.Interface (DelegateResponse, FrontendRequest)
+import Network.WebSockets (PendingConnection)
+
+-- | The config for the delegate server
+data DelegateServerConfig = DelegateServerConfig
+  { dlgt'host :: IP
+  -- ^ the host of the delegate server
+  , dlgt'port :: PortNumber
+  -- ^ the port number the delegate server receives input at
+  , dlgt'tick :: Int
+  -- ^ the amount of milliseconds, the thread should wait
+  }
+
+data DelegateServerLog
+  = Started PortNumber
+  | FrontendConnected
+  | FrontendInput FrontendRequest
+  | DelegateOutput DelegateResponse
+  | DelegateError DelegateError
+  deriving stock (Eq, Show, Generic)
+
+instance Pretty DelegateServerLog where
+  pretty = \case
+    Started port -> "Started Server at Port" <> pretty (show port)
+    FrontendConnected -> "Frontend connected to Server"
+    DelegateOutput out -> "Delegate output" <> line <> viaShow out
+    FrontendInput inp -> "Frontend input" <> line <> viaShow inp
+    DelegateError err -> "Delegate error" <> line <> pretty err
+
+-- FIXME: needs actual error
+data DelegateError = FrontendNoParse
+  deriving stock (Eq, Show, Generic)
+
+instance Pretty DelegateError where
+  pretty = \case
+    FrontendNoParse -> "Could not parse the input provided by the frontend"
+
+type DelegateTracer = TracerT DelegateServerLog
+
+class MonadTracer t m | m -> t where
+  trace :: t -> m ()
+
+-- | a transformer that provides a tracer
+newtype TracerT t m a = TracerT {runTracerT :: ReaderT (Tracer m t) m a}
+  deriving newtype
+    ( Functor
+    , Applicative
+    , Monad
+    , MonadReader (Tracer m t)
+    , MonadIO
+    )
+
+-- these could be derived in a normal deriving clause but I feel better specifying
+-- the context myself
+deriving newtype instance MonadWriter w m => MonadWriter w (TracerT t m)
+deriving newtype instance MonadState s m => MonadState s (TracerT t m)
+
+mapTracerT :: (t1 -> t2) -> TracerT t1 m a -> TracerT t2 m a
+mapTracerT f = TracerT . withReaderT (contramap f) . runTracerT
+
+runWithTracer :: (forall b. n b -> m b) -> Tracer n t -> TracerT t m a -> m a
+runWithTracer natTrans tracer = flip runReaderT (natTracer natTrans tracer) . runTracerT
+
+runWithTracer' :: Tracer m t -> TracerT t m a -> m a
+runWithTracer' = runWithTracer id
+
+askTracer :: forall t m. Monad m => TracerT t m (Tracer m t)
+askTracer = ask @(Tracer m t)
+
+instance MonadTrans (TracerT t) where
+  lift = TracerT . lift
+
+instance (Monad m) => MonadTracer t (TracerT t m) where
+  trace t = ask >>= lift . flip traceWith t
+
+type ServerAppT m = PendingConnection -> m ()

delegate-app/Main.hs

@@ -1,49 +1,133 @@
 module Main (main) where
 
 -- Prelude imports
+
+-- Prelude imports
+import Hydra.Cardano.Api.Prelude (lookupEnv)
+import Hydra.Prelude (readMaybe, traverse_)
 import Prelude
 
 -- Haskell imports
-
 import Control.Concurrent (threadDelay)
-import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad (forever, (>=>))
+import Control.Monad.Extra (whenJust)
+import Control.Monad.State (MonadState (get), StateT, evalStateT, put)
+import Control.Monad.Trans
+import Control.Tracer (Tracer, contramap, stdoutTracer)
+import Data.Aeson (decode, encode)
+import Data.Maybe (fromMaybe)
+import Network.HTTP.Types (status200)
+import Network.Wai (Application, responseLBS)
+import Network.Wai.Handler.Warp (run)
+import Network.Wai.Handler.WebSockets (websocketsOr)
+import Network.WebSockets
+import Prettyprinter (Pretty (pretty))
+
+-- Hydra imports
+import Hydra.Network
 
 -- HydraAuction imports
 import HydraAuction.Delegate (
   DelegateEvent (Start),
-  DelegateInput (DelegateEvent),
+  DelegateInput (DelegateEvent, FrontendRequest),
   DelegateRunnerT,
   delegateStep,
   execDelegateRunnerT,
  )
+import HydraAuction.Delegate.Server (
+  DelegateError (FrontendNoParse),
+  DelegateServerConfig (DelegateServerConfig, dlgt'host, dlgt'port, dlgt'tick),
+  DelegateServerLog (DelegateError, DelegateOutput, FrontendConnected, FrontendInput, Started),
+  MonadTracer (trace),
+  ServerAppT,
+  TracerT,
+  askTracer,
+  dlgt'tick,
+  runWithTracer',
+ )
 
-eventsProducer :: Bool -> DelegateRunnerT IO (Maybe DelegateEvent)
+eventsProducer :: Monad m => Bool -> DelegateRunnerT m (Maybe DelegateEvent)
 eventsProducer thisIsFirstRun =
   if thisIsFirstRun
     then return $ Just Start
     else return Nothing
 
-consumer :: Maybe DelegateInput -> DelegateRunnerT IO ()
-consumer mInput = case mInput of
-  Just input -> do
-    delegateResponse <- delegateStep input
-    -- FIXME: send response to client
-    liftIO $
-      putStrLn $
-        "Delegate responses for input: " <> show delegateResponse
-  Nothing -> return ()
+delegateServerApp ::
+  (MonadIO m, MonadTracer DelegateServerLog m) =>
+  Int ->
+  ServerAppT m
+delegateServerApp tick pending = do
+  connection <- liftIO $ acceptRequest pending
+  trace FrontendConnected
+  -- FIXME: we will probably have to do this in parallel, but how can we enqueue in the same
+  -- state? probably have to remodel this
+  execDelegateRunnerT $ flip evalStateT True $ mkRunner tick connection
+
+-- FIXME: remove concrete monads and make this tagless final (needs MonadDelegate)
+mkRunner ::
+  (MonadIO m, MonadTracer DelegateServerLog m) =>
+  Int ->
+  Connection ->
+  StateT Bool (DelegateRunnerT m) ()
+-- FIXME: we need to abort at some point but this doesn't seem
+-- to be implemented yet so we just go on
+mkRunner tick con = forever $ do
+  isFirstRun <- get
+  _ <- lift $ do
+    let encodeSend = liftIO . sendTextData con . encode
+    liftIO (receiveData con)
+      >>= ( \case
+              Nothing -> lift $ trace (DelegateError FrontendNoParse)
+              Just req -> do
+                lift . trace $ FrontendInput req
+                step <- delegateStep (FrontendRequest req)
+                lift $ traverse_ (trace . DelegateOutput) step
+                encodeSend step
+          )
+        -- yes, this is not nice, but hlint wants it so badly
+        . decode
 
-delegateTick :: Int
-delegateTick = 1_000
+    -- FIXME: more elaborate logic for eventsProducer
+    mdelegateEvent <- eventsProducer isFirstRun
+    whenJust (DelegateEvent <$> mdelegateEvent) $
+      delegateStep >=> encodeSend
+
+  liftIO $ threadDelay tick
+  put False
+
+runDelegateServer ::
+  DelegateServerConfig ->
+  TracerT DelegateServerLog IO ()
+runDelegateServer conf = do
+  trace (Started $ dlgt'port conf)
+  let fallback :: Application
+      fallback _req res =
+        res $
+          responseLBS status200 [("Content-Type", "text/plain")] "Websocket endpoint of delegate server"
+
+  tracer <- askTracer
+  liftIO $
+    run (fromIntegral $ dlgt'port conf) $
+      flip (websocketsOr defaultConnectionOptions) fallback $
+        runWithTracer' tracer . delegateServerApp (dlgt'tick conf)
 
 main :: IO ()
 main = do
   -- FIXME: cover either case. It probably should not be transformer.
-  _ <- execDelegateRunnerT $ go True
-  return ()
-  where
-    go thisIsFirstRun = do
-      mEvent <- eventsProducer thisIsFirstRun
-      consumer (DelegateEvent <$> mEvent)
-      liftIO $ threadDelay delegateTick
-      go False
+  port <- lookupEnv "port"
+
+  -- FIXME: do we need this?
+  let host :: IP = "127.0.0.1"
+      tick :: Int = 1_000
+
+      conf :: DelegateServerConfig
+      conf =
+        DelegateServerConfig
+          { dlgt'host = host
+          , dlgt'port = fromMaybe 8080 $ port >>= readMaybe
+          , dlgt'tick = tick
+          }
+      tracer :: Tracer IO DelegateServerLog
+      tracer = contramap (show . pretty) stdoutTracer
+
+  runWithTracer' tracer $ runDelegateServer conf

hydra-auction.cabal

@@ -183,9 +183,20 @@ executable hydra-auction
 executable hydra-auction-delegate
   import:         common-lang
   main-is:        Main.hs
+  other-modules:  HydraAuction.Delegate.Server
   hs-source-dirs: delegate-app
   ghc-options:    -threaded -rtsopts
-  build-depends:  hydra-auction
+  build-depends:
+    , cardano-api             >=1.35
+    , cardano-ledger-babbage
+    , cardano-ledger-core
+    , http-types
+    , hydra-auction
+    , plutus-cbor
+    , unliftio-core
+    , wai
+    , wai-websockets
+    , warp
 
 library
   import:          common-lang
@@ -217,6 +228,7 @@ library
     HydraAuction.Runner.Tracer
 
   build-depends:
+    , cardano-api
     , directory
     , hydra-cardano-api
     , hydra-cluster

src/HydraAuction/Delegate/Interface.hs

@@ -8,23 +8,29 @@ module HydraAuction.Delegate.Interface (
 -- Prelude imports
 import Prelude
 
+-- Haskell imports
+import GHC.Generics (Generic)
+
 -- Cardano imports
-import Cardano.Api.UTxO (UTxO)
+import Cardano.Api
 
 -- HydraAuction imports
 import HydraAuction.Types (AuctionTerms (..), Natural)
 
 data FrontendRequest
   = CommitStandingBid
       { auctionTerms :: AuctionTerms
-      , utxoToCommit :: UTxO
+      , utxoToCommit :: TxIn
       }
   | -- FIXME: commit full datum
     NewBid {bidAmount :: Natural}
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (ToJSON, FromJSON)
 
 data DelegateResponse
   = ClosingTxTemplate
   | HydraRequestError
   | AlreadyHasAuction
   | HasNoAuction
-  deriving stock (Show)
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (FromJSON, ToJSON)

src/HydraAuction/Types.hs

@@ -29,8 +29,10 @@ import PlutusTx.Prelude
 import Prelude qualified
 
 -- Haskell imports
+
+import Control.Monad ((<=<))
 import Control.Monad.Fail (fail)
-import Data.Aeson (FromJSON (..), ToJSON)
+import Data.Aeson (FromJSON (parseJSON), ToJSON)
 import GHC.Generics (Generic)
 
 -- Plutus imports
@@ -43,6 +45,7 @@ import PlutusTx.IsData.Class (FromData (fromBuiltinData), ToData (toBuiltinData)
 
 -- Hydra auction imports
 import HydraAuction.Addresses (VoucherCS)
+import HydraAuction.Plutus.Orphans ()
 
 -- Custom Natural
 
@@ -85,11 +88,7 @@ naturalToInt (Natural i) = i
 PlutusTx.makeLift ''Natural
 
 instance FromJSON Natural where
-  parseJSON x = do
-    int <- parseJSON x
-    case intToNatural int of
-      Just nat -> return nat
-      Nothing -> fail "Integer is not natural"
+  parseJSON = maybe (fail "Integer is not natural") return . intToNatural <=< parseJSON
 
 -- Base datatypes
 
@@ -142,6 +141,7 @@ data AuctionTerms = AuctionTerms
   -- announced this auction, to provide the auction lot to the auction.
   }
   deriving stock (Generic, Prelude.Show, Prelude.Eq)
+  deriving anyclass (ToJSON, FromJSON)
 
 PlutusTx.makeIsDataIndexed ''AuctionTerms [('AuctionTerms, 0)]
 PlutusTx.makeLift ''AuctionTerms