ghc 9.4.6

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

flake.lock

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

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

hbs2-core/hbs2-core.cabal

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

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
 

hbs2-git/hbs2-git.cabal

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

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
 

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

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
            ]
 

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 ]
+    ttl = Just $ lastDef 86400 [ x | ListVal (Key "ttl" [LitIntVal x]) <- args ]
-    owner = fromStringMay =<< lastMay [ Text.unpack o | ListVal @C (Key "owner" [LitStrVal o]) <- 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 ]
 

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

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

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

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
+instance (Monad m, HasConf m) => HasCfgValue PeerAcceptAnnounceKey AcceptAnnounce m where
-  cfgValue (PeerConfig syn) = fromMaybe (AcceptAnnounceFrom lst) fromAll
+  cfgValue = do
+    syn <- getConf
+    pure $ fromMaybe (AcceptAnnounceFrom (lst syn)) (fromAll syn)
     where
-      fromAll = headMay [ AcceptAnnounceAll | ListVal @C (Key s [SymbolVal "*"]) <- syn, s == kk ]
+      fromAll syn = headMay [ AcceptAnnounceAll | ListVal (Key s [SymbolVal "*"]) <- syn, s == kk ]
-      lst = Set.fromList $
+      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
 

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
+  flip runReaderT syn do
-  let whs = cfgValue @PeerWhiteListKey conf :: Set String
+    bls <- cfgValue @PeerBlackListKey
-  let blkeys = toKeys bls
+    whs <- cfgValue @PeerWhiteListKey
-  let wlkeys = toKeys (whs `Set.difference` bls)
+
-
+    let blkeys = toKeys bls
-
+    let wlkeys = toKeys (whs `Set.difference` bls)
-  let k = view peerSignKey pd
+
-  let blacklisted = k `Set.member` blkeys
+    let k = view peerSignKey pd
-  let whitelisted = Set.null wlkeys || (k `Set.member` wlkeys)
+    let blacklisted = k `Set.member` blkeys
-  pure $ blacklisted || not whitelisted
+    let whitelisted = Set.null wlkeys || (k `Set.member` wlkeys)
+    pure $ blacklisted || not whitelisted
 
 

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

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

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)
-            ]
-

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
 

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 listenConf      = runReader (cfgValue @PeerListenKey)  syn
-  let keyConf = cfgValue @PeerKeyFileKey conf
+  let keyConf         = runReader (cfgValue @PeerKeyFileKey) syn
-  let storConf = cfgValue @PeerStorageKey conf <&> StoragePrefix
+  let storConf        = runReader (cfgValue @PeerStorageKey) syn <&> StoragePrefix
-  let traceConf = cfgValue @PeerTraceKey conf :: FeatureSwitch
+  let traceConf       = runReader (cfgValue @PeerTraceKey)   syn
-  let debugConf = cfgValue @PeerDebugKey conf :: FeatureSwitch
+  let debugConf       = runReader (cfgValue @PeerDebugKey)   syn :: FeatureSwitch
-  let trace1Conf = cfgValue @PeerTrace1Key conf :: 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)
+  liftIO $ print $ pretty "debug: " <+> pretty (show debugConf)
-  debug $ pretty "trace1: " <+> pretty (show trace1Conf)
+  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
 

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)

hbs2-peer/hbs2-peer.cabal

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

hbs2-storage-simple/hbs2-storage-simple.cabal

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

hbs2-tests/hbs2-tests.cabal

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