diff --git a/examples/refchan-qblf/app/RefChanQBLFMain.hs b/examples/refchan-qblf/app/RefChanQBLFMain.hs index 77b28000..a754947b 100644 --- a/examples/refchan-qblf/app/RefChanQBLFMain.hs +++ b/examples/refchan-qblf/app/RefChanQBLFMain.hs @@ -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 diff --git a/flake.lock b/flake.lock index 233801db..092cba84 100644 --- a/flake.lock +++ b/flake.lock @@ -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": { diff --git a/flake.nix b/flake.nix index a72c9e51..f52bac50 100644 --- a/flake.nix +++ b/flake.nix @@ -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 diff --git a/hbs2-core/hbs2-core.cabal b/hbs2-core/hbs2-core.cabal index d3be5e3d..bcccd430 100644 --- a/hbs2-core/hbs2-core.cabal +++ b/hbs2-core/hbs2-core.cabal @@ -62,6 +62,7 @@ common shared-properties , StandaloneDeriving , TupleSections , TypeApplications + , TypeOperators , TypeFamilies , TemplateHaskell , ViewPatterns diff --git a/hbs2-git/git-hbs2/Main.hs b/hbs2-git/git-hbs2/Main.hs index ae90d2bc..737586cc 100644 --- a/hbs2-git/git-hbs2/Main.hs +++ b/hbs2-git/git-hbs2/Main.hs @@ -11,7 +11,6 @@ import HBS2.Net.Proto.Definition() import RunShow -import Data.Functor import Options.Applicative as O import Control.Monad diff --git a/hbs2-git/hbs2-git.cabal b/hbs2-git/hbs2-git.cabal index 023ab257..ad9e4407 100644 --- a/hbs2-git/hbs2-git.cabal +++ b/hbs2-git/hbs2-git.cabal @@ -51,6 +51,7 @@ common shared-properties , StandaloneDeriving , TupleSections , TypeApplications + , TypeOperators , TypeFamilies diff --git a/hbs2-git/lib/HBS2Git/App.hs b/hbs2-git/lib/HBS2Git/App.hs index 2d2a7857..374f274d 100644 --- a/hbs2-git/lib/HBS2Git/App.hs +++ b/hbs2-git/lib/HBS2Git/App.hs @@ -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 diff --git a/hbs2-git/lib/HBS2Git/Config.hs b/hbs2-git/lib/HBS2Git/Config.hs index e1c8126a..a03ac007 100644 --- a/hbs2-git/lib/HBS2Git/Config.hs +++ b/hbs2-git/lib/HBS2Git/Config.hs @@ -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 diff --git a/hbs2-git/lib/HBS2Git/Encryption.hs b/hbs2-git/lib/HBS2Git/Encryption.hs index 5c6146fe..224fbf06 100644 --- a/hbs2-git/lib/HBS2Git/Encryption.hs +++ b/hbs2-git/lib/HBS2Git/Encryption.hs @@ -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 ] diff --git a/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs b/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs index 46c2bf52..dc241f90 100644 --- a/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs +++ b/hbs2-git/lib/HBS2Git/Encryption/KeyInfo.hs @@ -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 ] diff --git a/hbs2-git/reposync/ReposyncMain.hs b/hbs2-git/reposync/ReposyncMain.hs index 94ed9c48..1f41a87b 100644 --- a/hbs2-git/reposync/ReposyncMain.hs +++ b/hbs2-git/reposync/ReposyncMain.hs @@ -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 diff --git a/hbs2-peer/app/Bootstrap.hs b/hbs2-peer/app/Bootstrap.hs index a1b17d09..b05ea6c7 100644 --- a/hbs2-peer/app/Bootstrap.hs +++ b/hbs2-peer/app/Bootstrap.hs @@ -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 diff --git a/hbs2-peer/app/Brains.hs b/hbs2-peer/app/Brains.hs index 0b01d3e7..0430c6a3 100644 --- a/hbs2-peer/app/Brains.hs +++ b/hbs2-peer/app/Brains.hs @@ -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 diff --git a/hbs2-peer/app/CheckBlockAnnounce.hs b/hbs2-peer/app/CheckBlockAnnounce.hs index 2f3ec9a3..3784a98f 100644 --- a/hbs2-peer/app/CheckBlockAnnounce.hs +++ b/hbs2-peer/app/CheckBlockAnnounce.hs @@ -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 diff --git a/hbs2-peer/app/CheckPeer.hs b/hbs2-peer/app/CheckPeer.hs index 4e6fca4f..c5edf61e 100644 --- a/hbs2-peer/app/CheckPeer.hs +++ b/hbs2-peer/app/CheckPeer.hs @@ -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 diff --git a/hbs2-peer/app/DownloadQ.hs b/hbs2-peer/app/DownloadQ.hs index e7e73dde..336bf9cf 100644 --- a/hbs2-peer/app/DownloadQ.hs +++ b/hbs2-peer/app/DownloadQ.hs @@ -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 diff --git a/hbs2-peer/app/HttpWorker.hs b/hbs2-peer/app/HttpWorker.hs index 52bc4e66..f608fa8a 100644 --- a/hbs2-peer/app/HttpWorker.hs +++ b/hbs2-peer/app/HttpWorker.hs @@ -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 diff --git a/hbs2-peer/app/PeerConfig.hs b/hbs2-peer/app/PeerConfig.hs index 3879cd0f..876a412a 100644 --- a/hbs2-peer/app/PeerConfig.hs +++ b/hbs2-peer/app/PeerConfig.hs @@ -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) - ] - diff --git a/hbs2-peer/app/PeerInfo.hs b/hbs2-peer/app/PeerInfo.hs index 58598c3a..69c43da7 100644 --- a/hbs2-peer/app/PeerInfo.hs +++ b/hbs2-peer/app/PeerInfo.hs @@ -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 diff --git a/hbs2-peer/app/PeerMain.hs b/hbs2-peer/app/PeerMain.hs index 73daa2bc..becaa173 100644 --- a/hbs2-peer/app/PeerMain.hs +++ b/hbs2-peer/app/PeerMain.hs @@ -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 diff --git a/hbs2-peer/app/PeerTypes.hs b/hbs2-peer/app/PeerTypes.hs index 0f61718d..ef300096 100644 --- a/hbs2-peer/app/PeerTypes.hs +++ b/hbs2-peer/app/PeerTypes.hs @@ -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) diff --git a/hbs2-peer/hbs2-peer.cabal b/hbs2-peer/hbs2-peer.cabal index 16660132..03a12b6c 100644 --- a/hbs2-peer/hbs2-peer.cabal +++ b/hbs2-peer/hbs2-peer.cabal @@ -122,6 +122,7 @@ common shared-properties , TupleSections , TypeApplications , TypeFamilies + , TypeOperators library diff --git a/hbs2-storage-simple/hbs2-storage-simple.cabal b/hbs2-storage-simple/hbs2-storage-simple.cabal index 0931ed13..7f3b19ab 100644 --- a/hbs2-storage-simple/hbs2-storage-simple.cabal +++ b/hbs2-storage-simple/hbs2-storage-simple.cabal @@ -51,6 +51,7 @@ common shared-properties , StandaloneDeriving , TupleSections , TypeApplications + , TypeOperators , TypeFamilies diff --git a/hbs2-tests/hbs2-tests.cabal b/hbs2-tests/hbs2-tests.cabal index df56619c..3b235edf 100644 --- a/hbs2-tests/hbs2-tests.cabal +++ b/hbs2-tests/hbs2-tests.cabal @@ -95,6 +95,7 @@ common shared-properties , StandaloneDeriving , TupleSections , TypeApplications + , TypeOperators , TypeFamilies