{-# 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