Monad.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- | Effect stack for Synapse operations
--
-- = The Monad
--
-- @
-- SynapseM = ExceptT SynapseError (ReaderT SynapseEnv IO)
-- @
--
-- Provides:
-- - Error handling via 'SynapseError'
-- - Environment with cache and cycle detection
-- - IO for network calls
module Synapse.Monad
  ( -- * The Monad
    SynapseM
  , runSynapseM
  , runSynapseM'

    -- * Environment
  , SynapseEnv(..)
  , seHost
  , sePort
  , initEnv
  , initEnvAt
  , defaultEnv
  , withRequestContext
  , withViewKey
  , viewQualified

    -- * Errors
  , SynapseError(..)
  , BackendErrorType(..)
  , TransportContext(..)
  , TransportErrorCategory(..)
  , throwNav
  , throwTransport
  , throwTransportWith
  , throwParse
  , throwBackend

    -- * Cycle Detection
  , checkCycle
  , withFreshVisited

    -- * Cache Operations
  , lookupCache
  , insertCache

    -- * Logging
  , getLogger
  ) where

import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, asks)
import Control.Monad.Except (MonadError, ExceptT, runExceptT, throwError)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HM
import Data.HashSet (HashSet)
import qualified Data.HashSet as HS
import Data.Hashable (Hashable)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef')
import Data.Text (Text)
import qualified Data.Text as T

import Synapse.Schema.Types
import Synapse.Backend.Discovery (Backend(..))
import Synapse.Endpoint (Endpoint(..), plainAt)
import qualified Synapse.Log as Log
import qualified Katip

-- | Environment for Synapse operations
data SynapseEnv = SynapseEnv
  { seEndpoint :: !Endpoint                   -- ^ Where the hub is reached (SCAFFOLD-21: ws or wss, its path)
  , seBackend :: !Text                        -- ^ Backend name (first CLI argument)
  , seCache   :: !(IORef (HashMap PluginHash PluginSchema))  -- ^ Schema cache
  , seVisited :: !(IORef (HashSet PluginHash))               -- ^ Cycle detection
  , seLogger  :: !Log.Logger                  -- ^ Structured logger
  , seToken   :: !(Maybe Text)                -- ^ JWT sent as Cookie: access_token=<jwt>
  , seCookies :: ![(Text, Text)]              -- ^ SAFE-S04/REQ-5: extra cookies for WS upgrade
  , seHeaders :: ![(Text, Text)]              -- ^ SAFE-S04/REQ-5: extra headers for WS upgrade
  , seViewKey :: !(Maybe Text)                -- ^ AUTH-8: the caller's view (its hash, else its kind); qualifies every cache key
  }

-- | Errors that can occur during Synapse operations
data SynapseError
  = NavError NavError
  | TransportError Text                    -- Keep for compatibility
  | TransportErrorContext TransportContext -- NEW: with context
  | ParseError Text
  | ValidationError Text
  | BackendError BackendErrorType [Backend]
  deriving stock (Show, Eq)

-- | Backend-specific error types
data BackendErrorType
  = BackendNotFound Text
  | BackendUnreachable Text
  | NoBackendsAvailable
  | ProtocolHandshakeFailed Text Int  -- host, port - _info request failed/timed out
  deriving stock (Show, Eq)

-- | Transport error with connection details and categorization
data TransportContext = TransportContext
  { tcMessage  :: Text
  , tcHost     :: Text
  , tcPort     :: Int
  , tcBackend  :: Text
  , tcPath     :: Path
  , tcCategory :: TransportErrorCategory
  } deriving stock (Show, Eq)

-- | Categories of transport errors
data TransportErrorCategory
  = ConnectionRefused
  | ConnectionTimeout
  | ProtocolError
  | UnknownTransportError
  deriving stock (Show, Eq)

-- | The Synapse monad stack
newtype SynapseM a = SynapseM
  { unSynapseM :: ExceptT SynapseError (ReaderT SynapseEnv IO) a
  }
  deriving newtype
    ( Functor
    , Applicative
    , Monad
    , MonadIO
    , MonadReader SynapseEnv
    , MonadError SynapseError
    )

-- Note: PluginHash is a type alias for Text, which is already Hashable

-- | Run a SynapseM action with the given environment
runSynapseM :: SynapseEnv -> SynapseM a -> IO (Either SynapseError a)
runSynapseM env action = runReaderT (runExceptT (unSynapseM action)) env

-- | Run a SynapseM action with default host/port and specified backend (with error-level logger)
runSynapseM' :: Text -> SynapseM a -> IO (Either SynapseError a)
runSynapseM' backend action = do
  logger <- Log.makeLogger Katip.ErrorS
  env <- defaultEnv backend logger
  runSynapseM env action

-- | The hub's host.
seHost :: SynapseEnv -> Text
seHost = epHost . seEndpoint

-- | The hub's port.
sePort :: SynapseEnv -> Int
sePort = epPort . seEndpoint

-- | Initialize environment with given host/port/backend/logger/token, for a
-- hub at plain @ws://HOST:PORT/@ ('initEnvAt' for any address).
-- Extra cookies/headers default to empty; use 'withRequestContext' to add
-- them after construction (SAFE-S04/REQ-5).
initEnv :: Text -> Int -> Text -> Log.Logger -> Maybe Text -> IO SynapseEnv
initEnv host port = initEnvAt (plainAt host port)

-- | SCAFFOLD-21: 'initEnv' for a hub at any address (@wss://…/ws@ too).
initEnvAt :: Endpoint -> Text -> Log.Logger -> Maybe Text -> IO SynapseEnv
initEnvAt ep backend logger token = do
  cache <- newIORef HM.empty
  visited <- newIORef HS.empty
  pure SynapseEnv
    { seEndpoint = ep
    , seBackend = backend
    , seCache   = cache
    , seVisited = visited
    , seLogger  = logger
    , seToken   = token
    , seCookies = []
    , seHeaders = []
    , seViewKey = Nothing
    }

-- | Augment a SynapseEnv with extra cookies and headers for the WS upgrade.
-- (SAFE-S04/REQ-5: --cookie/--header CLI flags and SYNAPSE_COOKIE_*/SYNAPSE_HEADER_* env)
withRequestContext :: [(Text, Text)] -> [(Text, Text)] -> SynapseEnv -> SynapseEnv
withRequestContext cookies headers env = env
  { seCookies = seCookies env ++ cookies
  , seHeaders = seHeaders env ++ headers
  }

-- | Default environment (localhost:4444, requires backend and logger)
defaultEnv :: Text -> Log.Logger -> IO SynapseEnv
defaultEnv backend logger = initEnv "127.0.0.1" 4444 backend logger Nothing

-- | Throw a navigation error
throwNav :: NavError -> SynapseM a
throwNav = throwError . NavError

-- | Throw a transport error
throwTransport :: Text -> SynapseM a
throwTransport = throwError . TransportError

-- | Throw a parse error
throwParse :: Text -> SynapseM a
throwParse = throwError . ParseError

-- | Throw a backend error
throwBackend :: BackendErrorType -> [Backend] -> SynapseM a
throwBackend errorType backends = throwError (BackendError errorType backends)

-- | Throw a transport error with context
throwTransportWith :: TransportContext -> SynapseM a
throwTransportWith = throwError . TransportErrorContext

-- ============================================================================
-- Cycle Detection
-- ============================================================================

-- | Check for cycles before descending into a child
-- Throws 'Cycle' error if hash was already visited
checkCycle :: PluginHash -> Path -> SynapseM ()
checkCycle hash path = do
  visitedRef <- asks seVisited
  visited <- liftIO $ readIORef visitedRef
  when (hash `HS.member` visited) $
    throwNav $ Cycle hash path
  liftIO $ modifyIORef' visitedRef (HS.insert hash)

-- | Run an action with a fresh visited set, restoring afterwards
-- Used at the start of each navigation to reset cycle detection
withFreshVisited :: SynapseM a -> SynapseM a
withFreshVisited action = do
  ref <- asks seVisited
  old <- liftIO $ readIORef ref
  liftIO $ writeIORef ref HS.empty
  result <- action
  liftIO $ writeIORef ref old
  pure result

-- ============================================================================
-- Cache Operations
-- ============================================================================

-- | Look up a schema in the cache by hash
lookupCache :: PluginHash -> SynapseM (Maybe PluginSchema)
lookupCache hash = do
  cacheRef <- asks seCache
  key <- asks (\e -> viewQualified (seViewKey e) hash)
  cache <- liftIO $ readIORef cacheRef
  pure $ HM.lookup key cache

-- | Insert a schema into the cache
insertCache :: PluginHash -> PluginSchema -> SynapseM ()
insertCache hash schema = do
  cacheRef <- asks seCache
  key <- asks (\e -> viewQualified (seViewKey e) hash)
  liftIO $ modifyIORef' cacheRef (HM.insert key schema)

-- | AUTH-8: a cache key under the caller's view — @VIEW/HASH@, or the hash
-- alone on a hub with no view (as before AUTH). Two callers' views of one
-- hub never share an entry, even where the hub gave a schema one hash in
-- both.
viewQualified :: Maybe Text -> Text -> Text
viewQualified Nothing hash = hash
viewQualified (Just v) hash
  | T.null v = hash
  | otherwise = v <> "/" <> hash

-- | AUTH-8: the view this env's calls see (from @_info@).
withViewKey :: Maybe Text -> SynapseEnv -> SynapseEnv
withViewKey v env = env { seViewKey = v }

-- ============================================================================
-- Logging and Config
-- ============================================================================

-- | Get the logger from the environment
getLogger :: SynapseM Log.Logger
getLogger = asks seLogger