voidlizard
/
hbs2
mirror of https://github.com/voidlizard/hbs2
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

ghc 9.4.6

This commit is contained in:
Dmitry Zuikov 2023-10-16 06:13:27 +03:00
parent 4d25594b6d
commit 246518cd34
24 changed files with 127 additions and 189 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
examples/refchan-qblf/app/RefChanQBLFMain.hs
View File

@ -17,7 +17,6 @@ import HBS2.Net.Proto.RefChan
import HBS2.Net.Proto.AnyRef
import HBS2.Data.Types.SignedBox
import HBS2.Net.Messaging.Unix
import HBS2.Net.Proto.Definition
import HBS2.Data.Bundle
import HBS2.Net.Auth.Credentials
import HBS2.Data.Detect
@ -31,22 +30,18 @@ import QBLF.Proto
import Demo.QBLF.Transactions
import Data.Config.Suckless
import Data.Config.Suckless.KeyValue
import Data.Ord
import Control.Monad.Trans.Maybe
import Codec.Serialise
import Control.Monad.Reader
import Data.ByteString(ByteString)
import Data.ByteString.Char8 qualified as BS
import Data.ByteString.Lazy qualified as LBS
import Data.Functor
import Data.List qualified as List
import Lens.Micro.Platform hiding ((.=))
import Options.Applicative hiding (info)
import Options.Applicative qualified as O
import System.Directory
import Data.HashSet (HashSet)
import Data.HashSet qualified as HashSet
import Data.HashMap.Strict (HashMap)
import Data.HashMap.Strict qualified as HashMap
@ -55,21 +50,13 @@ import Data.Word
import System.Random
import UnliftIO
import Data.Time.Clock.POSIX (getPOSIXTime)
import Data.Aeson hiding (json)
import Web.Scotty hiding (request,header)
import Web.Scotty qualified as Scotty
import Network.HTTP.Types.Status
import Data.Monoid (mconcat)
import Data.Cache (Cache)
import Data.Cache qualified as Cache
import Control.Monad.Except
import Streaming.Prelude qualified as S
{- HLINT ignore "Use newtype instead of data" -}
-- TODO: config
@ -93,7 +80,7 @@ instance {-# OVERLAPPING #-} (HasConf m, HasCfgKey HttpPortOpt (Maybe Int) m) =>
cfgValue = val <$> getConf
where
val syn = lastMay [ fromIntegral e
| ListVal @C (Key s [LitIntVal e]) <- syn, s == key @HttpPortOpt @(Maybe Int) @m
| ListVal (Key s [LitIntVal e]) <- syn, s == key @HttpPortOpt @(Maybe Int) @m
]
instance Monad m => HasCfgKey RefChanOpt (Maybe String) m where

6
flake.lock
View File

@ -212,11 +212,11 @@
},
"nixpkgs": {
"locked": {
"lastModified": 1687946342,
"narHash": "sha256-vRxti8pOuXS0rJmqjbD8ueEEFXWSK22ISHoCWkhgzzg=",
"lastModified": 1697009197,
"narHash": "sha256-viVRhBTFT8fPJTb1N3brQIpFZnttmwo3JVKNuWRVc3s=",
"owner": "nixos",
"repo": "nixpkgs",
"rev": "1c851e8c92b76a00ce84167984a7ec7ba2b1f29c",
"rev": "01441e14af5e29c9d27ace398e6dd0b293e25a54",
"type": "github"
},
"original": {

1
flake.nix
View File

@ -70,7 +70,6 @@ outputs = { self, nixpkgs, haskell-flake-utils, ... }@inputs:
shellExtBuildInputs = {pkgs}: with pkgs; [
haskellPackages.haskell-language-server
haskellPackages.cbor-tool
haskellPackages.htags
pkg-config
inputs.hspup.packages.${pkgs.system}.default

1
hbs2-core/hbs2-core.cabal
View File

@ -62,6 +62,7 @@ common shared-properties
, StandaloneDeriving
, TupleSections
, TypeApplications
, TypeOperators
, TypeFamilies
, TemplateHaskell
, ViewPatterns

1
hbs2-git/git-hbs2/Main.hs
View File

@ -11,7 +11,6 @@ import HBS2.Net.Proto.Definition()
import RunShow
import Data.Functor
import Options.Applicative as O
import Control.Monad

1
hbs2-git/hbs2-git.cabal
View File

@ -51,6 +51,7 @@ common shared-properties
, StandaloneDeriving
, TupleSections
, TypeApplications
, TypeOperators
, TypeFamilies

23
hbs2-git/lib/HBS2Git/App.hs
View File

@ -47,7 +47,6 @@ import Data.Foldable
import Data.Either
import Control.Monad.Reader
import Control.Monad.Trans.Resource
-- import Control.Monad.Except (runExceptT,throwError)
import Control.Monad.Except (runExceptT)
import Control.Monad.Catch
import Crypto.Saltine.Core.Sign qualified as Sign
@ -59,22 +58,15 @@ import Data.Set qualified as Set
import Lens.Micro.Platform
import System.Directory
import System.FilePattern.Directory
-- import System.FilePath
import System.FilePath
import System.Process.Typed
import Text.InterpolatedString.Perl6 (qc)
-- import Network.HTTP.Simple
-- import Network.HTTP.Types.Status
import Control.Concurrent.STM (flushTQueue)
import Codec.Serialise
import Data.HashMap.Strict qualified as HashMap
import Data.HashSet qualified as HashSet
import Data.List qualified as List
import Data.Text qualified as Text
-- import Data.IORef
-- import System.IO.Unsafe (unsafePerformIO)
-- import Data.Cache qualified as Cache
-- import Control.Concurrent.Async
import System.Environment
import Prettyprinter.Render.Terminal
@ -172,7 +164,7 @@ runWithRPC action = do
(_, syn) <- configInit
let soname' = lastMay [ Text.unpack n
| ListVal @C (Key "rpc" [SymbolVal "unix", LitStrVal n]) <- syn
| ListVal (Key "rpc" [SymbolVal "unix", LitStrVal n]) <- syn
]
soname <- race ( pause @'Seconds 1) (maybe detectRPC pure soname') `orDie` "hbs2-peer rpc timeout!"
@ -537,29 +529,28 @@ loadKeys = do
trace $ "loadKeys"
kp <- liftIO $ lookupEnv "HBS2KEYS"
found1 <- findKeyFiles =<< liftIO (lookupEnv "HBS2KEYS")
found2 <- findKeyFiles =<< getGlobalOption "key"
found <- liftIO $ mapM canonicalizePath (found1 <> found2)
let enc = [ args | (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : args)) <- conf ]
let enc = [ args | (ListVal (SymbolVal "encrypted" : (LitStrVal r) : args)) <- conf ]
let owners = [ fromStringMay @(PubKey 'Encrypt Schema) (Text.unpack o)
| ListVal @C (Key "owner" [LitStrVal o]) <- universeBi enc
| ListVal (Key "owner" [LitStrVal o]) :: Syntax C <- universeBi enc
] & catMaybes & HashSet.fromList
let members = [ fromStringMay @(PubKey 'Encrypt Schema) (Text.unpack o)
| ListVal @C (Key "member" [LitStrVal o]) <- universeBi enc
| ListVal (Key "member" [LitStrVal o]) :: Syntax C <- universeBi enc
] & catMaybes & HashSet.fromList
let decrypt = [ Text.unpack o
| ListVal @C (Key "decrypt" [LitStrVal o]) <- conf
| ListVal (Key "decrypt" [LitStrVal o]) <- conf
]
let keyrings = [ Text.unpack o | ListVal @C (Key "keyring" [LitStrVal o]) <- universeBi enc
let keyrings = [ Text.unpack o | (ListVal (Key "keyring" [LitStrVal o]) :: Syntax C)
<- universeBi enc
] <> decrypt <> found
& List.nub

2
hbs2-git/lib/HBS2Git/Config.hs
View File

@ -61,7 +61,7 @@ configPath _ = liftIO do
<&> fromRight mempty
let core = or [True | SymbolVal @C "core" <- universeBi gitConf]
let bare = or [True | ListVal @C [SymbolVal @C "bare", _, SymbolVal @C "true"] <- universeBi gitConf ]
let bare = or [True | ListVal [SymbolVal @C "bare", _, SymbolVal "true"] <- universeBi gitConf ]
let repo = or [True | SymbolVal @C "repositoryformatversion" <- universeBi gitConf ]
if core && bare && repo then do

2
hbs2-git/lib/HBS2Git/Encryption.hs
View File

@ -30,7 +30,7 @@ isRefEncrypted ref = do
conf <- getConf
let ee = [ True
| (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : _)) <- conf
| (ListVal (SymbolVal "encrypted" : (LitStrVal r) : _)) <- conf
, fromStringMay (Text.unpack r) == Just ref
]

8
hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs
View File

@ -35,7 +35,7 @@ instance Hashed HbSync KeyInfo where
keyInfoFrom :: POSIXTime -> Syntax C -> Maybe KeyInfo
keyInfoFrom t (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : args)) =
keyInfoFrom t (ListVal (SymbolVal "encrypted" : (LitStrVal r) : args)) =
KeyInfo <$> nonce
<*> ref
<*> owner
@ -44,11 +44,11 @@ keyInfoFrom t (ListVal @C (SymbolVal "encrypted" : (LitStrVal r) : args)) =
where
nonce = Just $ maybe 0 (round t `div`) ttl
ref = fromStringMay (Text.unpack r)
ttl = Just $ lastDef 86400 [ x | ListVal @C (Key "ttl" [LitIntVal x]) <- args ]
owner = fromStringMay =<< lastMay [ Text.unpack o | ListVal @C (Key "owner" [LitStrVal o]) <- args ]
ttl = Just $ lastDef 86400 [ x | ListVal (Key "ttl" [LitIntVal x]) <- args ]
owner = fromStringMay =<< lastMay [ Text.unpack o | ListVal (Key "owner" [LitStrVal o]) <- args ]
members = Just $ HashSet.fromList
$ catMaybes
[ fromStringMay (Text.unpack o) | ListVal @C (Key "member" [LitStrVal o]) <- args ]
[ fromStringMay (Text.unpack o) | ListVal (Key "member" [LitStrVal o]) <- args ]
-- keypath = lastMay [ Text.unpack p | ListVal @C (Key "keyring" [LitStrVal p]) <- args ]

4
hbs2-git/reposync/ReposyncMain.hs
View File

@ -165,12 +165,12 @@ withConfig cfg m = do
entries root syn = do
let findKeys w = [ Text.unpack p
| ListVal @C (Key "decrypt" [LitStrVal p]) <- w
| ListVal (Key "decrypt" [LitStrVal p]) <- w
]
let reflogs = catMaybes [ (,) <$> fromStringMay @(RefLogKey HBS2Basic) (Text.unpack o)
<*> pure (findKeys args)
| ListVal @C (Key "reflog" (LitStrVal o : args)) <- syn
| ListVal (Key "reflog" (LitStrVal o : args)) <- syn
]
forM reflogs $ \(repo, keys) -> do

21
hbs2-peer/app/Bootstrap.hs
View File

@ -1,4 +1,5 @@
{-# Language AllowAmbiguousTypes #-}
{-# Language TypeOperators #-}
module Bootstrap where
import HBS2.Data.Types.Peer
@ -6,21 +7,18 @@ import HBS2.Prelude
import HBS2.Net.Proto.Types
import HBS2.Net.Proto.Peer
import HBS2.Clock
import HBS2.Net.IP.Addr
import HBS2.Net.Proto.Sessions
import PeerConfig
import HBS2.System.Logger.Simple
import Data.Functor
import Network.DNS
import Control.Monad.Reader
import Data.ByteString.Char8 qualified as B8
import Data.Foldable
import Data.Maybe
import Data.Set qualified as Set
import Data.Set (Set)
import Control.Monad
import Network.Socket
import Control.Monad.Trans.Maybe
@ -28,10 +26,10 @@ data PeerDnsBootStrapKey
data PeerKnownPeer
instance HasCfgKey PeerDnsBootStrapKey (Set String) where
instance Monad m => HasCfgKey PeerDnsBootStrapKey (Set String) m where
key = "bootstrap-dns"
instance HasCfgKey PeerKnownPeer [String] where
instance Monad m => HasCfgKey PeerKnownPeer (Set String) m where
key = "known-peer"
-- FIXME: tcp-addr-support-bootstrap
@ -46,7 +44,8 @@ bootstrapDnsLoop :: forall e m . ( HasPeer e
, MonadIO m
)
=> PeerConfig -> m ()
bootstrapDnsLoop conf = do
bootstrapDnsLoop (PeerConfig syn) = do
pause @'Seconds 2
@ -55,7 +54,8 @@ bootstrapDnsLoop conf = do
forever do
debug "I'm a bootstrapLoop"
let dns = cfgValue @PeerDnsBootStrapKey conf <> Set.singleton "bootstrap.hbs2.net"
dns <- runReaderT(cfgValue @PeerDnsBootStrapKey) syn
<&> (<> Set.singleton "bootstrap.hbs2.net")
-- FIXME: utf8-domains
for_ (Set.toList dns) $ \dn -> do
@ -83,14 +83,15 @@ knownPeersPingLoop :: forall e m . ( HasPeer e
, e ~ L4Proto
, MonadIO m)
=> PeerConfig -> m ()
knownPeersPingLoop conf = do
knownPeersPingLoop (PeerConfig syn) = do
-- FIXME: add validation and error handling
-- FIXME: tcp-addr-support-2
let parseKnownPeers xs = do
let pa = foldMap (maybeToList . fromStringMay) xs
mapM fromPeerAddr pa
knownPeers' <- liftIO $ parseKnownPeers $ cfgValue @PeerKnownPeer conf
let them = runReader (cfgValue @PeerKnownPeer) syn & Set.toList
knownPeers' <- liftIO $ parseKnownPeers them
forever do
forM_ knownPeers' (sendPing @e)
pause @'Minutes 20

10
hbs2-peer/app/Brains.hs
View File

@ -1,6 +1,7 @@
{-# Language AllowAmbiguousTypes #-}
{-# Language UndecidableInstances #-}
{-# Language TemplateHaskell #-}
{-# Language TypeOperators #-}
module Brains
( module Brains
, module HBS2.Peer.Brains
@ -21,6 +22,7 @@ import PeerConfig
import Crypto.Saltine.Core.Box qualified as Encrypt
import Control.Monad
import Control.Monad.Reader
import Control.Exception
import Control.Concurrent.STM
import Database.SQLite.Simple
@ -43,10 +45,9 @@ import UnliftIO (MonadUnliftIO(..),async,race)
data PeerBrainsDb
instance HasCfgKey PeerBrainsDb (Maybe String) where
instance Monad m => HasCfgKey PeerBrainsDb (Maybe String) m where
key = "brains"
newtype CommitCmd = CommitCmd { onCommited :: IO () }
data BasicBrains e =
@ -593,7 +594,8 @@ newBasicBrains cfg = liftIO do
let stateDb = sdir </> "brains.db"
let brains = fromMaybe ":memory:" $ cfgValue @PeerBrainsDb cfg
brains <- runReaderT (cfgValue @PeerBrainsDb @(Maybe String)) cfg
<&> fromMaybe ":memory:"
unless ( brains == ":memory:" ) do
here <- doesFileExist brains
@ -737,7 +739,7 @@ runBasicBrains cfg brains = do
let (PeerConfig syn) = cfg
let polls = catMaybes (
[ (tp,n,) <$> fromStringMay @(PubKey 'Sign (Encryption e)) (Text.unpack ref)
| ListVal @C (Key "poll" [SymbolVal tp, LitIntVal n, LitStrVal ref]) <- syn
| ListVal (Key "poll" [SymbolVal tp, LitIntVal n, LitStrVal ref]) <- syn
] )
void $ async $ do

24
hbs2-peer/app/CheckBlockAnnounce.hs
View File

@ -1,4 +1,4 @@
{-# Language MultiWayIf #-}
{-# Language TypeOperators #-}
module CheckBlockAnnounce where
import HBS2.Prelude.Plated
@ -19,6 +19,7 @@ import DownloadQ
import HBS2.System.Logger.Simple
import Control.Monad.Trans.Maybe
import Control.Monad.Reader
import Data.Set qualified as Set
import Data.Set (Set)
import Lens.Micro.Platform
@ -39,19 +40,20 @@ instance Pretty AcceptAnnounce where
instance HasCfgKey PeerAcceptAnnounceKey AcceptAnnounce where
instance Monad m => HasCfgKey PeerAcceptAnnounceKey AcceptAnnounce m where
key = "accept-block-announce"
instance HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce where
cfgValue (PeerConfig syn) = fromMaybe (AcceptAnnounceFrom lst) fromAll
instance (Monad m, HasConf m) => HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce m where
cfgValue = do
syn <- getConf
pure $ fromMaybe (AcceptAnnounceFrom (lst syn)) (fromAll syn)
where
fromAll = headMay [ AcceptAnnounceAll | ListVal @C (Key s [SymbolVal "*"]) <- syn, s == kk ]
lst = Set.fromList $
fromAll syn = headMay [ AcceptAnnounceAll | ListVal (Key s [SymbolVal "*"]) <- syn, s == kk ]
lst syn = Set.fromList $
catMaybes [ fromStringMay @(PubKey 'Sign (Encryption L4Proto)) (Text.unpack e)
| ListVal @C (Key s [LitStrVal e]) <- syn, s == kk
| ListVal (Key s [LitStrVal e]) <- syn, s == kk
]
kk = key @PeerAcceptAnnounceKey @AcceptAnnounce
kk = key @PeerAcceptAnnounceKey @AcceptAnnounce @m
acceptAnnouncesFromPeer :: forall e m . ( MonadIO m
@ -65,13 +67,13 @@ acceptAnnouncesFromPeer :: forall e m . ( MonadIO m
=> PeerConfig
-> PeerAddr e
-> m Bool
acceptAnnouncesFromPeer conf pa = runPlus do
acceptAnnouncesFromPeer conf@(PeerConfig syn) pa = runPlus do
pip <- lift (fromPeerAddr @e pa)
pd <- toMPlus =<< lift (find @e (KnownPeerKey pip) id)
let accptAnn = cfgValue @PeerAcceptAnnounceKey conf :: AcceptAnnounce
let accptAnn = runReader (cfgValue @PeerAcceptAnnounceKey) syn
guard =<< peerBanned conf pd

31
hbs2-peer/app/CheckPeer.hs
View File

@ -7,6 +7,7 @@ import HBS2.Net.Proto.Types
import PeerTypes
import PeerConfig
import Control.Monad.Reader
import Data.Set qualified as Set
import Data.Set (Set)
import Lens.Micro.Platform
@ -15,29 +16,31 @@ import Lens.Micro.Platform
data PeerBlackListKey
data PeerWhiteListKey
instance HasCfgKey PeerBlackListKey (Set String) where
instance Monad m => HasCfgKey PeerBlackListKey (Set String) m where
key = "blacklist"
instance HasCfgKey PeerWhiteListKey (Set String) where
instance Monad m => HasCfgKey PeerWhiteListKey (Set String) m where
key = "whitelist"
peerBanned :: forall e m . ( Monad m, FromStringMaybe (PubKey 'Sign (Encryption e))
peerBanned :: forall e m . ( Monad m
, FromStringMaybe (PubKey 'Sign (Encryption e))
, Ord (PubKey 'Sign (Encryption e))
)
=> PeerConfig
-> PeerData e -> m Bool
peerBanned conf pd = do
peerBanned (PeerConfig syn) pd = do
let bls = cfgValue @PeerBlackListKey conf :: Set String
let whs = cfgValue @PeerWhiteListKey conf :: Set String
let blkeys = toKeys bls
let wlkeys = toKeys (whs `Set.difference` bls)
let k = view peerSignKey pd
let blacklisted = k `Set.member` blkeys
let whitelisted = Set.null wlkeys || (k `Set.member` wlkeys)
pure $ blacklisted || not whitelisted
flip runReaderT syn do
bls <- cfgValue @PeerBlackListKey
whs <- cfgValue @PeerWhiteListKey
let blkeys = toKeys bls
let wlkeys = toKeys (whs `Set.difference` bls)
let k = view peerSignKey pd
let blacklisted = k `Set.member` blkeys
let whitelisted = Set.null wlkeys || (k `Set.member` wlkeys)
pure $ blacklisted || not whitelisted

8
hbs2-peer/app/DownloadQ.hs
View File

@ -23,12 +23,10 @@ import Control.Concurrent.STM.TSem
import Data.ByteString.Char8 qualified as B8
import Data.List (nub)
import Data.Maybe
import Data.Functor
import Data.Function
import Control.Exception
import Control.Monad
import Control.Monad.Reader
import Control.Concurrent.Async
import System.IO
downloadLogAppend :: forall e m . ( MonadIO m
@ -48,7 +46,7 @@ downloadQueue :: forall e m . ( MyPeer e
, EventListener e (DownloadReq e) m
) => PeerConfig -> DownloadEnv e -> m ()
downloadQueue conf denv = do
downloadQueue (PeerConfig syn) denv = do
sto <- getStorage
hq <- liftIO newTQueueIO
@ -56,7 +54,7 @@ downloadQueue conf denv = do
pause @'Seconds 2
let qfile' = cfgValue @PeerDownloadLogKey conf :: Maybe String
let qfile' = runReader (cfgValue @PeerDownloadLogKey) syn
subscribe @e DownloadReqKey $ \(DownloadReqData h) -> do
liftIO $ atomically $ writeTQueue hq h

7
hbs2-peer/app/HttpWorker.hs
View File

@ -1,3 +1,4 @@
{-# Language TypeOperators #-}
module HttpWorker where
import HBS2.Prelude
@ -13,14 +14,12 @@ import PeerTypes
import PeerConfig
import RefLog ( doRefLogBroadCast )
import Data.Functor
import Data.ByteString.Lazy qualified as LBS
import Network.HTTP.Types.Status
import Network.Wai.Middleware.RequestLogger
import Text.InterpolatedString.Perl6 (qc)
import Web.Scotty
import Codec.Serialise (deserialiseOrFail)
import Data.Function ((&))
import Data.Aeson (object, (.=))
import Control.Monad.Reader
import Lens.Micro.Platform (view)
@ -36,10 +35,10 @@ httpWorker :: forall e s m . ( MyPeer e
, e ~ L4Proto
) => PeerConfig -> AnnMetaData -> DownloadEnv e -> m ()
httpWorker conf pmeta e = do
httpWorker (PeerConfig syn) pmeta e = do
sto <- getStorage
let port' = cfgValue @PeerHttpPortKey conf <&> fromIntegral
let port' = runReader (cfgValue @PeerHttpPortKey) syn <&> fromIntegral
penv <- ask
maybe1 port' none $ \port -> liftIO do

84
hbs2-peer/app/PeerConfig.hs
View File

@ -5,6 +5,7 @@ module PeerConfig
( module PeerConfig
, module Data.Config.Suckless.Syntax
, module Data.Config.Suckless.Parse
, module Data.Config.Suckless.KeyValue
) where
import HBS2.Prelude.Plated
@ -12,11 +13,10 @@ import HBS2.System.Logger.Simple
import Data.Config.Suckless.Syntax
import Data.Config.Suckless.Parse
import Data.Config.Suckless.KeyValue(HasConf(..))
import Data.Config.Suckless.KeyValue
import Control.Exception
import Control.Monad.Reader
import Data.Functor
import Data.Maybe
import System.Directory
import System.FilePath
@ -29,20 +29,6 @@ data FeatureSwitch =
FeatureOn | FeatureOff
deriving (Eq,Ord,Show,Generic)
-- FIXME: ASAP-switch-to-Suckless-KeyValue-1
class HasCfgKey a b where
-- type family CfgValue a :: Type
key :: Id
-- FIXME: ASAP-switch-to-Suckless-KeyValue-2
class HasCfgKey a b => HasCfgValue a b where
cfgValue :: PeerConfig -> b
type C = MegaParsec
pattern Key :: forall {c}. Id -> [Syntax c] -> [Syntax c]
pattern Key n ns <- SymbolVal n : ns
data PeerListenTCPKey
data PeerDownloadLogKey
data PeerHttpPortKey
@ -52,26 +38,34 @@ data PeerUseHttpDownload
instance Monad m => HasConf (ReaderT PeerConfig m) where
getConf = asks (\(PeerConfig syn) -> syn)
instance HasCfgKey PeerListenTCPKey (Maybe String) where
instance Monad m => HasCfgKey PeerListenTCPKey (Maybe String) m where
key = "listen-tcp"
instance HasCfgKey PeerHttpPortKey (Maybe Integer) where
instance Monad m => HasCfgKey PeerHttpPortKey (Maybe Integer) m where
key = "http-port"
instance HasCfgKey PeerTcpProbeWaitKey (Maybe Integer) where
instance Monad m => HasCfgKey PeerTcpProbeWaitKey (Maybe Integer) m where
key = "tcp-probe-wait"
instance HasCfgKey PeerUseHttpDownload FeatureSwitch where
instance Monad m => HasCfgKey PeerUseHttpDownload b m where
key = "http-download"
instance HasCfgKey PeerDownloadLogKey (Maybe String) where
instance Monad m => HasCfgKey PeerDownloadLogKey (Maybe String) m where
key = "download-log"
data PeerKnownPeersFile
instance HasCfgKey PeerKnownPeersFile [String] where
instance Monad m => HasCfgKey PeerKnownPeersFile (Set String) m where
key = "known-peers-file"
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a b m) => HasCfgValue a FeatureSwitch m where
cfgValue = lastDef FeatureOff . val <$> getConf
where
val syn = [ if e == "on" then FeatureOn else FeatureOff
| ListVal (Key s [SymbolVal e]) <- syn, s == key @a @b @m
]
cfgName :: FilePath
cfgName = "config"
@ -136,7 +130,7 @@ getRpcSocketNameM = do
syn <- getConf
let soname = lastDef rpcSoDef [ Text.unpack n
| ListVal @C (Key "rpc" [SymbolVal "unix", LitStrVal n]) <- syn
| ListVal (Key "rpc" [SymbolVal "unix", LitStrVal n]) <- syn
]
pure soname
@ -174,7 +168,8 @@ peerConfigRead mbfp = do
confData' <- parseConf cfgPath
knownPeersFiles <- mapM (canonicalizePath' dir) (cfgValue @PeerKnownPeersFile $ PeerConfig confData')
knownPeersFiles <- flip runReaderT confData' $ (Set.toList <$> cfgValue @PeerKnownPeersFile)
>>= mapM (canonicalizePath' dir)
knownPeersConfData <- concat <$> mapM parseConf knownPeersFiles
@ -198,44 +193,3 @@ peerConfigRead mbfp = do
else pure x
canonicalizeConfPaths _ _ x = pure x
instance {-# OVERLAPPABLE #-} (IsString b, HasCfgKey a (Maybe b)) => HasCfgValue a (Maybe b) where
cfgValue (PeerConfig syn) = val
where
val =
lastMay [ fromString (show $ pretty e)
| ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Maybe b)
]
instance {-# OVERLAPPABLE #-} (HasCfgKey a (Maybe Integer)) => HasCfgValue a (Maybe Integer) where
cfgValue (PeerConfig syn) = val
where
val =
lastMay [ e
| ListVal @C (Key s [LitIntVal e]) <- syn, s == key @a @(Maybe Integer)
]
instance (HasCfgKey a FeatureSwitch) => HasCfgValue a FeatureSwitch where
cfgValue (PeerConfig syn) = val
where
val =
lastDef FeatureOff
[ FeatureOn
| ListVal @C (Key s [SymbolVal (Id e)]) <- syn, s == key @a @FeatureSwitch, e == "on"
]
instance {-# OVERLAPPABLE #-} (IsString b, HasCfgKey a [b]) => HasCfgValue a [b] where
cfgValue (PeerConfig syn) = val
where
val = [ fromString (show $ pretty e)
| ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @[b]
]
instance {-# OVERLAPPABLE #-} (Ord b, IsString b, HasCfgKey a (Set b)) => HasCfgValue a (Set b) where
cfgValue (PeerConfig syn) = Set.fromList val
where
val = [ fromString (show $ pretty e)
| ListVal @C (Key s [LitStrVal e]) <- syn, s == key @a @(Set b)
]

8
hbs2-peer/app/PeerInfo.hs
View File

@ -1,12 +1,12 @@
{-# Language TemplateHaskell #-}
{-# Language AllowAmbiguousTypes #-}
{-# Language TypeOperators #-}
module PeerInfo where
import HBS2.Actors.Peer
import HBS2.Clock
import HBS2.Data.Types
import HBS2.Events
import HBS2.Net.Auth.Credentials
import HBS2.Net.PeerLocator
import HBS2.Net.Proto.Event.PeerExpired
import HBS2.Net.Proto.Peer
@ -38,7 +38,7 @@ import Data.HashMap.Strict qualified as HashMap
data PeerPingIntervalKey
-- TODO: ping-interval-specifically-for-peer
instance HasCfgKey PeerPingIntervalKey (Maybe Integer) where
instance Monad m => HasCfgKey PeerPingIntervalKey (Maybe Integer) m where
key = "ping-interval"
@ -149,13 +149,13 @@ peerPingLoop :: forall e m . ( HasPeerLocator e m
, e ~ L4Proto
)
=> PeerConfig -> PeerEnv e -> m ()
peerPingLoop cfg penv = do
peerPingLoop (PeerConfig syn) penv = do
e <- ask
pl <- getPeerLocator @e
let pingTime = cfgValue @PeerPingIntervalKey cfg
let pingTime = runReader (cfgValue @PeerPingIntervalKey) syn
& fromMaybe 30
& realToFrac

50
hbs2-peer/app/PeerMain.hs
View File

@ -135,25 +135,25 @@ data PeerTrace1Key
data PeerProxyFetchKey
instance HasCfgKey PeerDebugKey FeatureSwitch where
instance Monad m => HasCfgKey PeerDebugKey a m where
key = "debug"
instance HasCfgKey PeerTraceKey FeatureSwitch where
instance Monad m => HasCfgKey PeerTraceKey a m where
key = "trace"
instance HasCfgKey PeerTrace1Key FeatureSwitch where
instance Monad m => HasCfgKey PeerTrace1Key a m where
key = "trace1"
instance HasCfgKey PeerListenKey (Maybe String) where
instance Monad m => HasCfgKey PeerListenKey (Maybe String) m where
key = "listen"
instance HasCfgKey PeerKeyFileKey (Maybe String) where
instance Monad m => HasCfgKey PeerKeyFileKey (Maybe String) m where
key = "key"
instance HasCfgKey PeerStorageKey (Maybe String) where
instance Monad m => HasCfgKey PeerStorageKey (Maybe String) m where
key = "storage"
instance HasCfgKey PeerProxyFetchKey (Set String) where
instance Monad m => HasCfgKey PeerProxyFetchKey (Set String) m where
key = "proxy-fetch-for"
@ -522,23 +522,26 @@ runPeer opts = U.handle (\e -> myException e
>> respawn opts
) $ runResourceT do
threadSelf <- liftIO myThreadId
metrics <- liftIO newStore
xdg <- liftIO $ getXdgDirectory XdgData defStorePath <&> fromString
conf <- peerConfigRead (view peerConfig opts)
conf@(PeerConfig syn) <- peerConfigRead (view peerConfig opts)
-- let (PeerConfig syn) = conf
liftIO $ print $ pretty conf
let listenConf = cfgValue @PeerListenKey conf
let keyConf = cfgValue @PeerKeyFileKey conf
let storConf = cfgValue @PeerStorageKey conf <&> StoragePrefix
let traceConf = cfgValue @PeerTraceKey conf :: FeatureSwitch
let debugConf = cfgValue @PeerDebugKey conf :: FeatureSwitch
let trace1Conf = cfgValue @PeerTrace1Key conf :: FeatureSwitch
let listenConf = runReader (cfgValue @PeerListenKey) syn
let keyConf = runReader (cfgValue @PeerKeyFileKey) syn
let storConf = runReader (cfgValue @PeerStorageKey) syn <&> StoragePrefix
let traceConf = runReader (cfgValue @PeerTraceKey) syn
let debugConf = runReader (cfgValue @PeerDebugKey) syn :: FeatureSwitch
let trace1Conf = runReader (cfgValue @PeerTrace1Key) syn :: FeatureSwitch
let helpFetchKeys = runReader (cfgValue @PeerProxyFetchKey) syn & toKeys
let useHttpDownload = runReader (cfgValue @PeerUseHttpDownload) syn & (== FeatureOn)
let tcpListen = runReader (cfgValue @PeerListenTCPKey) syn & fromMaybe ""
let tcpProbeWait = runReader (cfgValue @PeerTcpProbeWaitKey) syn
& fromInteger @(Timeout 'Seconds) . fromMaybe 300
let listenSa = view listenOn opts <|> listenConf <|> Just defListenUDP
credFile <- pure (view peerCredFile opts <|> keyConf) `orDie` "credentials not set"
@ -547,8 +550,9 @@ runPeer opts = U.handle (\e -> myException e
debug $ "storage prefix:" <+> pretty pref
debug $ pretty "trace: " <+> pretty (show traceConf)
debug $ pretty "trace1: " <+> pretty (show trace1Conf)
liftIO $ print $ pretty "debug: " <+> pretty (show debugConf)
liftIO $ print $ pretty "trace: " <+> pretty (show traceConf)
liftIO $ print $ pretty "trace1: " <+> pretty (show trace1Conf)
when (traceConf == FeatureOn) do
setLogging @TRACE tracePrefix
@ -561,9 +565,6 @@ runPeer opts = U.handle (\e -> myException e
setLogging @TRACE1 tracePrefix
let helpFetchKeys = cfgValue @PeerProxyFetchKey conf & toKeys
let useHttpDownload = cfgValue @PeerUseHttpDownload conf & (== FeatureOn)
let ps = mempty
@ -605,7 +606,6 @@ runPeer opts = U.handle (\e -> myException e
denv <- newDownloadEnv brains
let tcpListen = cfgValue @PeerListenTCPKey conf & fromMaybe ""
let addr' = fromStringMay @(PeerAddr L4Proto) tcpListen
trace $ "TCP addr:" <+> pretty tcpListen <+> pretty addr'
@ -927,8 +927,6 @@ runPeer opts = U.handle (\e -> myException e
peerThread "encryptionHandshakeWorker"
(EncryptionKeys.encryptionHandshakeWorker @e conf pc encryptionHshakeAdapter)
let tcpProbeWait :: Timeout 'Seconds
tcpProbeWait = (fromInteger . fromMaybe 300) (cfgValue @PeerTcpProbeWaitKey conf)
peerThread "fillPeerMeta" (fillPeerMeta tcp tcpProbeWait)
@ -1025,7 +1023,7 @@ runPeer opts = U.handle (\e -> myException e
let k = view peerSignPk pc
let http = case cfgValue @PeerHttpPortKey conf :: Maybe Integer of
let http = case runReader (cfgValue @PeerHttpPortKey @(Maybe Integer)) syn of
Nothing -> mempty
Just p -> "http-port:" <+> pretty p

6
hbs2-peer/app/PeerTypes.hs
View File

@ -430,16 +430,16 @@ getKnownPeers = do
pure $ mconcat r
mkPeerMeta :: PeerConfig -> PeerEnv e -> AnnMetaData
mkPeerMeta conf penv = do
mkPeerMeta (PeerConfig syn) penv = do
let mHttpPort :: Maybe Integer
mHttpPort = cfgValue @PeerHttpPortKey conf <&> fromIntegral
mHttpPort = runReader (cfgValue @PeerHttpPortKey) syn
let mTcpPort :: Maybe Word16
mTcpPort =
(
fmap (\(L4Address _ (IPAddrPort (_, p))) -> p)
. fromStringMay @(PeerAddr L4Proto)
)
=<< cfgValue @PeerListenTCPKey conf
=<< runReader (cfgValue @PeerListenTCPKey) syn
annMetaFromPeerMeta . PeerMeta $ W.execWriter do
mHttpPort `forM` \p -> elem "http-port" (TE.encodeUtf8 . Text.pack . show $ p)
mTcpPort `forM` \p -> elem "listen-tcp" (TE.encodeUtf8 . Text.pack . show $ p)

1
hbs2-peer/hbs2-peer.cabal
View File

@ -122,6 +122,7 @@ common shared-properties
, TupleSections
, TypeApplications
, TypeFamilies
, TypeOperators
library

1
hbs2-storage-simple/hbs2-storage-simple.cabal
View File

@ -51,6 +51,7 @@ common shared-properties
, StandaloneDeriving
, TupleSections
, TypeApplications
, TypeOperators
, TypeFamilies

1
hbs2-tests/hbs2-tests.cabal
View File

@ -95,6 +95,7 @@ common shared-properties
, StandaloneDeriving
, TupleSections
, TypeApplications
, TypeOperators
, TypeFamilies