mirror of https://github.com/voidlizard/hbs2
274 lines
7.1 KiB
Haskell
274 lines
7.1 KiB
Haskell
{-# Language AllowAmbiguousTypes #-}
|
|
{-# Language UndecidableInstances #-}
|
|
{-# Language PatternSynonyms #-}
|
|
module PeerConfig
|
|
( module PeerConfig
|
|
, module Data.Config.Suckless.Syntax
|
|
, module Data.Config.Suckless.Parse
|
|
, module Data.Config.Suckless.KeyValue
|
|
) where
|
|
|
|
import HBS2.Prelude.Plated
|
|
import HBS2.Base58
|
|
import HBS2.Net.Auth.Credentials
|
|
|
|
import Data.Config.Suckless.Syntax
|
|
import Data.Config.Suckless.Parse
|
|
import Data.Config.Suckless.KeyValue
|
|
|
|
import PeerLogger
|
|
|
|
import Control.Exception
|
|
import Control.Monad.Reader
|
|
import Data.Maybe
|
|
import System.Directory
|
|
import System.FilePath
|
|
import Data.Set qualified as Set
|
|
import Data.Set (Set)
|
|
import Data.Text qualified as Text
|
|
import Text.InterpolatedString.Perl6 (qc)
|
|
|
|
data FeatureSwitch =
|
|
FeatureOn | FeatureOff
|
|
deriving (Eq,Ord,Show,Generic)
|
|
|
|
data PeerListenTCPKey
|
|
data PeerDownloadLogKey
|
|
data PeerHttpPortKey
|
|
data PeerTcpProbeWaitKey
|
|
data PeerUseHttpDownload
|
|
data PeerBrainsDBPath
|
|
|
|
data PeerListenKey
|
|
data PeerKeyFileKey
|
|
data PeerStorageKey
|
|
data PeerDebugKey
|
|
data PeerTraceKey
|
|
data PeerTrace1Key
|
|
data PeerProxyFetchKey
|
|
data PeerTcpSOCKS5
|
|
data PeerDownloadThreadKey
|
|
|
|
|
|
instance HasCfgKey PeerDebugKey a where
|
|
key = "debug"
|
|
|
|
instance HasCfgKey PeerTraceKey a where
|
|
key = "trace"
|
|
|
|
instance HasCfgKey PeerTrace1Key a where
|
|
key = "trace1"
|
|
|
|
instance HasCfgKey PeerListenKey (Maybe String) where
|
|
key = "listen"
|
|
|
|
instance HasCfgKey PeerKeyFileKey (Maybe String) where
|
|
key = "key"
|
|
|
|
instance HasCfgKey PeerStorageKey (Maybe String) where
|
|
key = "storage"
|
|
|
|
instance HasCfgKey PeerProxyFetchKey (Set String) where
|
|
key = "proxy-fetch-for"
|
|
|
|
-- NOTE: socks5-auth
|
|
-- Network.Simple.TCP does not support
|
|
-- SOCKS5 authentification
|
|
instance HasCfgKey PeerTcpSOCKS5 (Maybe String) where
|
|
key = "tcp.socks5"
|
|
|
|
instance HasCfgKey PeerDownloadThreadKey (Maybe Int) where
|
|
key = "download-threads"
|
|
|
|
|
|
|
|
newtype PeerHttpPort = PeerHttpPort (Maybe Integer)
|
|
deriving newtype (Pretty)
|
|
|
|
instance Monad m => HasConf (ReaderT PeerConfig m) where
|
|
getConf = asks (\(PeerConfig syn) -> syn)
|
|
|
|
instance HasCfgKey PeerListenTCPKey (Maybe String) where
|
|
key = "listen-tcp"
|
|
|
|
instance HasCfgKey PeerHttpPortKey b where
|
|
key = "http-port"
|
|
|
|
instance HasCfgKey PeerTcpProbeWaitKey (Maybe Integer) where
|
|
key = "tcp-probe-wait"
|
|
|
|
instance HasCfgKey PeerUseHttpDownload b where
|
|
key = "http-download"
|
|
|
|
instance HasCfgKey PeerBrainsDBPath b where
|
|
key = "brains-db"
|
|
|
|
instance HasCfgKey PeerDownloadLogKey (Maybe String) where
|
|
key = "download-log"
|
|
|
|
data PeerKnownPeersFile
|
|
|
|
instance HasCfgKey PeerKnownPeersFile (Set String) where
|
|
key = "known-peers-file"
|
|
|
|
|
|
instance {-# OVERLAPPABLE #-} (HasConf m, HasCfgKey a b) => 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
|
|
]
|
|
|
|
|
|
instance {-# OVERLAPPING #-} (HasConf m, HasCfgKey PeerHttpPortKey b, b ~ PeerHttpPort) => HasCfgValue PeerHttpPortKey b m where
|
|
cfgValue = val <$> getConf
|
|
where
|
|
val syn = do
|
|
let found = lastMay [ v
|
|
| ListVal (Key s [v]) <- syn, s == key @PeerHttpPortKey @b
|
|
]
|
|
case found of
|
|
Just (TextLike "off") -> PeerHttpPort Nothing
|
|
Just (LitIntVal n) -> (PeerHttpPort (Just n))
|
|
_ -> (PeerHttpPort (Just 5005))
|
|
|
|
cfgName :: FilePath
|
|
cfgName = "config"
|
|
|
|
newtype PeerConfig =
|
|
PeerConfig { fromPeerConfig :: [Syntax C] }
|
|
deriving newtype (Monoid, Semigroup, Pretty)
|
|
|
|
|
|
peerConfigDefault :: MonadIO m => m FilePath
|
|
peerConfigDefault = liftIO $
|
|
catchAny (getXdgDirectory XdgConfig "hbs2-peer" <&> (</> cfgName))
|
|
(const $ pure ".hbs2-peer.conf")
|
|
|
|
where
|
|
catchAny :: IO a -> (SomeException -> IO a) -> IO a
|
|
catchAny = Control.Exception.catch
|
|
|
|
peerStateDirDefault :: MonadIO m => m FilePath
|
|
peerStateDirDefault = liftIO $ getXdgDirectory XdgData "hbs2-peer"
|
|
|
|
defConfigData :: String
|
|
defConfigData = [qc|
|
|
|
|
listen "0.0.0.0:7351"
|
|
listen-tcp "0.0.0.0:10351"
|
|
|
|
; default storage is $HOME/.local/share/hbs2
|
|
; storage "./storage"
|
|
|
|
; edit path to a keyring file
|
|
; key "./key"
|
|
|]
|
|
|
|
peerConfigInit :: MonadIO m => Maybe FilePath -> m ()
|
|
peerConfigInit mbfp = liftIO do
|
|
|
|
debug $ "peerConfigInit" <+> pretty mbfp
|
|
|
|
defDir <- peerConfigDefault <&> takeDirectory
|
|
|
|
let dir = fromMaybe defDir mbfp
|
|
|
|
createDirectoryIfMissing True dir
|
|
|
|
let conf = dir </> cfgName
|
|
|
|
here <- liftIO $ doesFileExist conf
|
|
|
|
unless here do
|
|
let cfgPath = dir</>cfgName
|
|
appendFile cfgPath ";; hbs2-peer config file"
|
|
appendFile cfgPath defConfigData
|
|
|
|
cred0 <- newCredentials @'HBS2Basic
|
|
let keyname = "default.key"
|
|
let keypath = dir</>keyname
|
|
|
|
khere <- doesFileExist keypath
|
|
|
|
unless khere do
|
|
writeFile keypath (show $ pretty (AsCredFile $ AsBase58 cred0))
|
|
appendFile cfgPath [qc|key "./default.key"|]
|
|
appendFile cfgPath ""
|
|
|
|
peerConfDef :: String
|
|
peerConfDef = [qc|
|
|
|]
|
|
|
|
rpcSoDef :: FilePath
|
|
rpcSoDef = "/tmp/hbs2-rpc.socket"
|
|
|
|
getRpcSocketNameM :: HasConf m => m FilePath
|
|
getRpcSocketNameM = do
|
|
syn <- getConf
|
|
|
|
let soname = lastDef rpcSoDef [ Text.unpack n
|
|
| ListVal (Key "rpc" [SymbolVal "unix", LitStrVal n]) <- syn
|
|
]
|
|
pure soname
|
|
|
|
getRpcSocketName :: PeerConfig -> FilePath
|
|
getRpcSocketName = runReader getRpcSocketNameM
|
|
|
|
peerConfigRead :: MonadIO m => Maybe FilePath -> m PeerConfig
|
|
peerConfigRead mbfp = do
|
|
|
|
peerConfigInit mbfp
|
|
|
|
debug $ "peerConfigRead" <+> pretty mbfp
|
|
|
|
xdg <- peerConfigDefault
|
|
|
|
let cfgPath = maybe xdg (</> cfgName) mbfp
|
|
let dir = takeDirectory cfgPath
|
|
|
|
debug $ "searching config" <+> pretty cfgPath
|
|
|
|
here <- liftIO $ doesFileExist cfgPath
|
|
|
|
if not here then do
|
|
debug "no config found"
|
|
pure mempty
|
|
|
|
else do
|
|
|
|
-- FIXME: config-parse-error-handling
|
|
-- Handle parse errors
|
|
|
|
debug $ pretty cfgPath
|
|
|
|
let parseConf f = liftIO $ readFile f <&> parseTop <&> either mempty id
|
|
|
|
confData' <- parseConf cfgPath
|
|
|
|
knownPeersFiles <- flip runReaderT confData' $ (Set.toList <$> cfgValue @PeerKnownPeersFile)
|
|
>>= mapM (canonicalizePath' dir)
|
|
|
|
knownPeersConfData <- concat <$> mapM parseConf knownPeersFiles
|
|
|
|
let confData = confData' <> either mempty id (parseTop peerConfDef) <> knownPeersConfData
|
|
|
|
-- debug $ pretty confData
|
|
|
|
config <- transformBiM (canonicalizeConfPaths ["key", "storage", "download-log", "state-dir"] dir) confData
|
|
|
|
pure $ PeerConfig config
|
|
where
|
|
canonicalizePath' :: MonadIO m => FilePath -> FilePath -> m FilePath
|
|
canonicalizePath' dir = liftIO . canonicalizePath . (dir </>)
|
|
|
|
canonicalizeConfPaths :: MonadIO m => [Id] -> FilePath -> Syntax C -> m (Syntax C)
|
|
canonicalizeConfPaths keys dir x@(List co (Key k [LitStrVal path])) =
|
|
if k `elem` keys
|
|
then do
|
|
canonicalPath <- canonicalizePath' dir $ Text.unpack path
|
|
pure $ List @C co [Symbol co k, Literal co (mkLit (Text.pack canonicalPath))]
|
|
else pure x
|
|
canonicalizeConfPaths _ _ x = pure x
|
|
|