{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} module Network.MoeSocks.Bootstrap where import Control.Lens import Control.Monad.Except (ExceptT, throwError) import Control.Monad.Writer hiding (listen) import Data.Aeson hiding (Result) import Data.Aeson.Lens (_Object, _JSON) import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text.Lens (_Text) import qualified Data.HashMap.Strict as H import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.IO as TIO import qualified Network.MoeSocks.Type.Bootstrap.Config as C import qualified Network.MoeSocks.Type.Bootstrap.Option as O import Network.MoeSocks.Default (defaultConfig) import Network.MoeSocks.Encrypt (safeMethods, unsafeMethods) import Network.MoeSocks.Helper ((-), debug_, io, toHaskellNamingConvention) import Prelude hiding ((-), take) asList :: ([(Text, Value)] -> [(Text, Value)]) -> Value -> Value asList f = over _Object - H.fromList . f . H.toList toReadableConfig :: Value -> Value toReadableConfig = asList - each . _1 %~ T.tail showConfig :: C.Config -> Text showConfig = review _JSON . toReadableConfig . review _JSON withGateOptions :: O.Options -> IO a -> IO () withGateOptions someOptions aIO = do let _br = putStrLn "" if someOptions ^. O.listMethods then do _br putStrLn "Recommended:" itraverse_ (\k _ -> putStrLn - "\t\t" <> k ^. _Text) - safeMethods _br putStrLn "Supported:" itraverse_ (\k _ -> putStrLn - "\t\t" <> k ^. _Text) - unsafeMethods else if someOptions ^. O.showDefaultConfig then putStrLn - showConfig defaultConfig ^. _Text else () <$ aIO loadConfig :: O.Options -> ExceptT String IO C.Config loadConfig someOptions = do let _maybeFilePath = someOptions ^. O.configFile _v <- case _maybeFilePath of Nothing -> pure - Just - Object mempty Just _filePath -> fmap (preview _JSON) - io - TIO.readFile - _filePath ^. _Text let fixConfig:: Text -> Text fixConfig x = let _remoteHost = "remoteHost" _remotePort = "remotePort" _localHost = "localHost" fixes = Map.fromList [ ("server" , _remoteHost ) , ("remote" , _remoteHost ) , ("remoteAddress", _remoteHost ) , ("server_port" , _remotePort ) , ("local" , _localHost ) , ("localAddress" , _localHost ) , ("local_address", _localHost ) ] in fixes ^? ix x & fromMaybe x toParsableConfig :: Value -> Value toParsableConfig = asList - each . _1 %~ ( T.cons '_' . toHaskellNamingConvention . fixConfig ) filterEssentialConfig :: Value -> Value filterEssentialConfig = over _Object - \_obj -> foldl (flip H.delete) _obj - [ "_password" ] insertConfig :: Value -> Value -> Value insertConfig (Object _from) = over _Object (_from `H.union`) insertConfig _ = const Null insertParams :: [(Text, Value)] -> Value -> Value insertParams _from = over _Object (H.fromList _from `H.union`) fallbackConfig :: Value -> Value -> Value fallbackConfig = flip insertConfig optionalConfig = filterEssentialConfig - toJSON defaultConfig _maybeConfig = -- trace' "JSON: " _v >>= decode . encode . fallbackConfig optionalConfig . insertParams (someOptions ^. O.params) . toParsableConfig case _maybeConfig of Nothing -> do let _r = execWriter - do tell "\n" case _maybeFilePath of Just _filePath -> do tell "Failed to parse configuration file: " tell _filePath tell "\n" tell "Example: \n" tell - showConfig defaultConfig <> "\n" Nothing -> do tell "The password argument '-k' is required.\n" tell "Alternatively, use '-c' to provide a " tell "configuration file.\n" tell "\n" tell "Use '-h' to show help text" tell "\n" throwError - _r ^. _Text Just _config -> do let configStr = showConfig _config ^. _Text :: String io - debug_ - "Using config: " <> configStr pure - _config