diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index 0a3ca67e..54de5014 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -116,7 +116,10 @@ httpWorker :: forall e s m . ( MyPeer e httpWorker (PeerConfig syn) pmeta = do sto <- getStorage - let port' = runReader (cfgValue @PeerHttpPortKey) syn <&> fromIntegral + + let port' = runReader (cfgValue @PeerHttpPortKey @PeerHttpPort) syn + & (fmap fromIntegral . coerce) + penv <- ask maybe1 port' none $ \port -> liftIO do diff --git a/hbs2-peer/app/PeerConfig.hs b/hbs2-peer/app/PeerConfig.hs index 49bbe8d1..e11c51b1 100644 --- a/hbs2-peer/app/PeerConfig.hs +++ b/hbs2-peer/app/PeerConfig.hs @@ -39,13 +39,16 @@ data PeerTcpProbeWaitKey data PeerUseHttpDownload data PeerBrainsDBPath +newtype PeerHttpPort = PeerHttpPort (Maybe Integer) + deriving newtype (Pretty) + instance Monad m => HasConf (ReaderT PeerConfig m) where getConf = asks (\(PeerConfig syn) -> syn) instance HasCfgKey PeerListenTCPKey (Maybe String) where key = "listen-tcp" -instance HasCfgKey PeerHttpPortKey (Maybe Integer) where +instance HasCfgKey PeerHttpPortKey b where key = "http-port" instance HasCfgKey PeerTcpProbeWaitKey (Maybe Integer) where @@ -73,6 +76,19 @@ instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a b) => HasCfgValue a Featur | ListVal (Key s [SymbolVal e]) <- syn, s == key @a @b ] + +instance {-# OVERLAPPING #-} (HasConf m, HasCfgKey PeerHttpPortKey b, b ~ PeerHttpPort) => HasCfgValue PeerHttpPortKey b m where + cfgValue = val <$> getConf + where + val syn = do + let found = lastMay [ v + | ListVal (Key s [v]) <- syn, s == key @PeerHttpPortKey @b + ] + case found of + Just (TextLike "off") -> PeerHttpPort Nothing + Just (LitIntVal n) -> (PeerHttpPort (Just n)) + _ -> (PeerHttpPort (Just 5005)) + cfgName :: FilePath cfgName = "config" diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 849f046c..7ad62f24 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -1333,9 +1333,9 @@ runPeer opts = respawnOnError opts $ do let k = view peerSignPk pc - let http = case runReader (cfgValue @PeerHttpPortKey @(Maybe Integer)) syn of - Nothing -> mempty - Just p -> "http-port:" <+> pretty p + let http = case runReader (cfgValue @PeerHttpPortKey @PeerHttpPort) syn of + PeerHttpPort Nothing -> mempty + PeerHttpPort (Just p) -> "http-port:" <+> pretty p let rpc = getRpcSocketName conf diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index e30ef63b..fc7841a4 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -43,6 +43,7 @@ import Control.Monad.Trans.Maybe import Control.Monad.Reader import Control.Monad.Writer qualified as W import Data.ByteString.Lazy (ByteString) +import Data.Coerce import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap import Data.List qualified as L @@ -288,8 +289,10 @@ getKnownPeers = do mkPeerMeta :: PeerConfig -> PeerEnv e -> AnnMetaData mkPeerMeta (PeerConfig syn) penv = do + let mHttpPort :: Maybe Integer - mHttpPort = runReader (cfgValue @PeerHttpPortKey) syn + mHttpPort = coerce $ runReader (cfgValue @PeerHttpPortKey @PeerHttpPort) syn + let mTcpPort :: Maybe Word16 mTcpPort = (