Merge pull request 'Split haskell lib, fanout to L1, and get balance' (…

…#3) from demo3 into develop

Reviewed-on: https://code.obsidian.systems/HydraNow/hydra-pay/pulls/3

ChangeLog.md

@@ -2,6 +2,13 @@
 
 This project's release branch is `master`. This log is written from the perspective of the release branch: when changes hit `master`, they are considered released.
 
+### Version v0.2.0
+
+* *Breaking change*: Split haskell library into two parts: hydra-pay-core and hydra-pay. hydra-pay includes database components that cannot be included in frontend clients, while hydra-pay-core includes common components that are compatible with both frontend and backend clients.
+* Add fanout to L1 workflow
+* Add hydra balance retrieval
+* Various stability improvements
+
 ## Version v0.1.1
 
 * First party haskell library with extensible logging, payment channel api, upgraded persistence, upgraded node and head management, wallet and key generation facilities

default.nix

@@ -33,6 +33,7 @@ let
       packages =
       {
         hydra-pay = ./hydra-pay;
+        hydra-pay-core = ./hydra-pay-core;
         cardano-transaction = pkgs.hackGet ./dep/cardano-transaction-builder;
         bytestring-aeson-orphans = pkgs.hackGet ./dep/bytestring-aeson-orphans;
       };

dep/cardano-transaction-builder/github.json

@@ -3,6 +3,6 @@
   "repo": "cardano-transaction-builder",
   "branch": "dango",
   "private": false,
-  "rev": "cf841b3efb97515c5e05f88f9254d2ed09e3d142",
-  "sha256": "16h1x5qwg08fwpkfmbw34hlsbp1czmhdginvwbzvqg6f9r7fr3ls"
+  "rev": "75977f3f977bff86a84a6e6e2c2adb4d7d63c59f",
+  "sha256": "1752g8jkpkkksjwxpz3wm2gl1qd1v1q1g698yyqjaqc17hmvynbp"
 }

hydra-pay-core/hydra-pay-core.cabal

@@ -0,0 +1,63 @@
+name:          hydra-pay-core
+version:       0.1
+cabal-version: >=1.10
+build-type:    Simple
+
+library
+  hs-source-dirs:     src
+  build-depends:
+      aeson
+    , aeson-gadt-th
+    , base
+    , beam-core
+    , bytestring
+    , cardano-addresses
+    , cardano-api
+    , cardano-ledger-core
+    , constraints-extras
+    , containers
+    , directory
+    , hexstring
+    , lens
+    , mtl
+    , network
+    , process
+    , stm
+    , text
+    , time
+    , transformers
+
+  default-extensions:
+    ConstraintKinds
+    DataKinds
+    DeriveGeneric
+    DerivingStrategies
+    FlexibleContexts
+    FlexibleInstances
+    GADTs
+    LambdaCase
+    MultiParamTypeClasses
+    OverloadedStrings
+    QuantifiedConstraints
+    RankNTypes
+    RecursiveDo
+    ScopedTypeVariables
+    TypeApplications
+    TypeFamilies
+    UndecidableInstances
+
+  exposed-modules:
+    HydraPay.Cardano.Hydra.Api
+    HydraPay.Cardano.Hydra.Api.ClientInput
+    HydraPay.Cardano.Hydra.ChainConfig
+    HydraPay.Cardano.Hydra.RunningHead
+    HydraPay.Logging
+    HydraPay.Orphans
+    HydraPay.PaymentChannel
+    HydraPay.PortRange
+    HydraPay.Types
+    HydraPay.Utils
+
+  ghc-options:
+    -Wall -Wredundant-constraints -Wincomplete-uni-patterns
+    -Wincomplete-record-updates -O -fno-show-valid-hole-fits

hydra-pay/src/HydraPay/Cardano/Hydra/Api.hs → hydra-pay-core/src/HydraPay/Cardano/Hydra/Api.hs

@@ -1,34 +1,27 @@
 -- |
 
-module HydraPay.Cardano.Hydra.Api where
+module HydraPay.Cardano.Hydra.Api
+  ( module HydraPay.Cardano.Hydra.Api
+  , module X
+  )
+  where
 
 import GHC.Generics
 import Data.Aeson
 import Data.Text (Text)
 import Data.Set (Set)
+import HydraPay.Cardano.Hydra.Api.ClientInput as X hiding (utxo, transaction)
 
-data ClientInput
-  = Init
-  | Abort
-  | Commit Value
-  | NewTx Value
-  | GetUTxO
-  | Close
-  | Contest
-  | Fanout
-  deriving (Generic, Show, Eq)
-
-instance FromJSON ClientInput
-instance ToJSON ClientInput
+type HeadId = Text
 
 data ServerOutput
   = PeerConnected {peer :: Value}
   | PeerDisconnected {peer :: Value}
-  | HeadIsInitializing {headId :: Value, parties :: Set Value}
-  | Committed {headId :: Value, party :: Value, utxo :: Value}
-  | HeadIsOpen {headId :: Value, utxo :: Value}
+  | HeadIsInitializing {headId :: HeadId, parties :: Set Value}
+  | Committed {headId :: HeadId, party :: Value, utxo :: Value}
+  | HeadIsOpen {headId :: HeadId, utxo :: Value}
   | HeadIsClosed
-      { headId :: Value
+      { headId :: HeadId
       , snapshotNumber :: Value
       , -- | Nominal deadline until which contest can be submitted and after
         -- which fanout is possible. NOTE: Use this only for informational
@@ -37,25 +30,25 @@ data ServerOutput
         -- sufficiently in time yet and we do not re-submit transactions (yet).
         contestationDeadline :: Value
       }
-  | HeadIsContested {headId :: Value, snapshotNumber :: Value}
-  | ReadyToFanout {headId :: Value}
-  | HeadIsAborted {headId :: Value, utxo :: Value}
-  | HeadIsFinalized {headId :: Value, utxo :: Value}
+  | HeadIsContested {headId :: HeadId, snapshotNumber :: Value}
+  | ReadyToFanout {headId :: HeadId}
+  | HeadIsAborted {headId :: HeadId, utxo :: Value}
+  | HeadIsFinalized {headId :: HeadId, utxo :: Value}
   | CommandFailed {clientInput :: ClientInput}
   | -- | Given transaction has been seen as valid in the Head. It is expected to
     -- eventually be part of a 'SnapshotConfirmed'.
-    TxValid {headId :: Value, transaction :: Value}
+    TxValid {headId :: HeadId, transaction :: Value}
   | -- | Given transaction was not not applicable to the given UTxO in time and
     -- has been dropped.
-    TxInvalid {headId :: Value, utxo :: Value, transaction :: Value, validationError :: Value}
+    TxInvalid {headId :: HeadId, utxo :: Value, transaction :: Value, validationError :: Value}
   | -- | Given snapshot was confirmed and included transactions can be
     -- considered final.
     SnapshotConfirmed
-      { headId :: Value
+      { headId :: HeadId
       , snapshot :: Value
       , signatures :: Value
       }
-  | GetUTxOResponse {headId :: Value, utxo :: Value}
+  | GetUTxOResponse {headId :: HeadId, utxo :: Value}
   | InvalidInput {reason :: String, input :: Text}
   | -- | A friendly welcome message which tells a client something about the
     -- node. Currently used for knowing what signing key the server uses (it

hydra-pay-core/src/HydraPay/Cardano/Hydra/Api/ClientInput.hs

@@ -0,0 +1,21 @@
+-- |
+
+module HydraPay.Cardano.Hydra.Api.ClientInput where
+
+import GHC.Generics
+import Data.Aeson
+
+
+data ClientInput
+  = Init
+  | Abort
+  | Commit {utxo :: Value}
+  | NewTx {transaction :: Value }
+  | GetUTxO
+  | Close
+  | Contest
+  | Fanout
+  deriving (Generic, Show, Eq)
+
+instance FromJSON ClientInput
+instance ToJSON ClientInput

hydra-pay-core/src/HydraPay/Cardano/Hydra/ChainConfig.hs

@@ -0,0 +1,12 @@
+{-# Language TemplateHaskell #-}
+module HydraPay.Cardano.Hydra.ChainConfig where
+
+import Control.Lens
+
+data HydraChainConfig = HydraChainConfig
+  { _hydraChainConfig_ledgerGenesis :: FilePath
+  , _hydraChainConfig_ledgerProtocolParams :: FilePath
+  }
+
+
+makeLenses ''HydraChainConfig

hydra-pay-core/src/HydraPay/Cardano/Hydra/RunningHead.hs

@@ -0,0 +1,52 @@
+module HydraPay.Cardano.Hydra.RunningHead where
+
+import Control.Concurrent
+import Control.Concurrent.STM
+import Data.Map (Map)
+import System.IO
+import System.Process
+
+import HydraPay.Cardano.Hydra.Api
+import HydraPay.PortRange
+import qualified Cardano.Api as Api
+
+-- | A running Hydra Head
+data RunningHydraHead = RunningHydraHead
+  { _hydraHead_status :: TVar HydraHeadStatus
+  , _hydraHead_handles :: Map Api.AddressAny HydraNode
+  }
+
+data HydraHeadStatus
+  = HydraHead_Uninitialized
+  | HydraHead_Initializing
+  | HydraHead_Open
+  | HydraHead_Closed
+  | HydraHead_Finalized
+  | HydraHead_Aborted
+
+type ProcessInfo = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+
+data HydraNode = HydraNode
+  { _hydraNode_apiPort :: Port
+  , _hydraNode_processInfo :: ProcessInfo
+  , _hydraNode_communicationThread :: ThreadId
+  , _hydraNode_status :: TVar HydraNodeStatus
+  , _hydraNode_pendingRequests :: TMVar (Map Int HydraNodeRequest)
+  , _hydraNode_requestQueue :: TBQueue ClientInput
+  }
+
+data HydraNodeStatus
+  = HydraNodeStatus_Unavailable
+  | HydraNodeStatus_Replaying
+  | HydraNodeStatus_Replayed
+  | HydraNodeStatus_PeersConnected
+  | HydraNodeStatus_Closed -- ^ TODO do we need this? Should we be removing this node after it is close? But what about if we haven't fanned out yet
+  deriving (Eq, Show)
+
+data HydraNodeRequest = HydraNodeRequest
+  { _hydraNodeRequest_id :: Int
+  , _hydraNodeRequest_clientInput :: ClientInput
+  , _hydraNodeRequest_mailbox :: TMVar ServerOutput
+  }
+
+

hydra-pay/src/HydraPay/Logging.hs → hydra-pay-core/src/HydraPay/Logging.hs

@@ -105,46 +105,50 @@ renderLog :: LogMessage -> T.Text
 renderLog (LogMessage l p c) =
   "[" <> (T.pack . show) l <> "] " <> p <> " - " <> c <> "\n"
 
-logReader :: LogConfig -> TBQueue LogMessage -> IO ()
-logReader settings queue = do
+logReader :: IORef (Handle, FilePath) -> LogConfig -> TBQueue LogMessage -> IO ()
+logReader logFileRef settings queue = do
   time <- getLocalTime
-  let
-    getLogFile = do
-      logFile <- aquireLogFile settings time
-      logFileRef <- newIORef logFile
-      pure logFileRef
-  bracket getLogFile (\ref -> do
-                       (h, _) <- readIORef ref
-                       hClose h) $ \logFileRef -> do
-    forever $ do
-      (fileHandle, filePath) <- readIORef logFileRef
-      msg <- atomically $ readTBQueue queue
-      let
-        handle = logHandle $ logMessage_level msg
-        renderered = renderLog msg
-
-      -- Log to the std stream and file handle
-      T.hPutStr handle renderered
-      T.hPutStr fileHandle renderered
-
-      -- Check if we should rotate, because enough time has passed, or the log is too big
-      currentTime <- getLocalTime
-      let
-        isSameDay = diffDays (localDay time) (localDay currentTime) == 0
-
-      logSize <- getFileSize filePath
-      when (not isSameDay || logSize >= logConfig_maxFileSize settings) $ do
-        newLogFile <- aquireLogFile settings currentTime
-        hClose fileHandle
-        writeIORef logFileRef newLogFile
-      pure ()
+  forever $ do
+    (fileHandle, filePath) <- readIORef logFileRef
+    msg <- atomically $ readTBQueue queue
+    let
+      handle = logHandle $ logMessage_level msg
+      renderered = renderLog msg
+
+    -- Log to the std stream and file handle
+    T.hPutStr handle renderered
+    T.hPutStr fileHandle renderered
+
+    -- Check if we should rotate, because enough time has passed, or the log is too big
+    currentTime <- getLocalTime
+    let
+      isSameDay = diffDays (localDay time) (localDay currentTime) == 0
+
+    logSize <- getFileSize filePath
+    when (not isSameDay || logSize >= logConfig_maxFileSize settings) $ do
+      hClose fileHandle
+      newLogFile <- aquireLogFile settings currentTime
+      writeIORef logFileRef newLogFile
+    pure ()
 
 withLogger :: LogConfig -> (Logger -> IO a) -> IO a
 withLogger settings action = do
   queue <- newTBQueueIO $ logConfig_maxQueueSize settings
-  bracket (forkIO $ logReader settings queue) killThread $ \_ -> do
+
+  -- Get the log file
+  time <- getLocalTime
+  logFile <- aquireLogFile settings time
+  logFileRef <- newIORef logFile
+
+  let
+    cleanupLogFileRef = do
+      (h, _) <- readIORef logFileRef
+      hClose h
+
+  bracket (forkIO $ logReader logFileRef settings queue) (\x -> cleanupLogFileRef >> killThread x) $ \_ -> do
     action $ Logger queue
 
+
 logM :: (MonadIO m, HasLogger a) => a -> LogLevel -> Text -> Text -> m ()
 logM a level subsystem msg = liftIO $ do
   atomically $ writeTBQueue q logMessage