-- |
-- Module      : Harmonic.Database
-- Description : Neo4j connection and query transport over the HTTP Query API
--
-- The single place the codebase talks to Neo4j. Queries go over the modern
-- HTTP endpoint (@POST \/db\/neo4j\/query\/v2@, Neo4j 5.23+\/2025.x), which
-- replaced both the Bolt binary protocol dependency and the deprecated
-- @tx\/commit@ HTTP API. HTTP keep-alive pooling in the shared
-- 'Network.HTTP.Client.Manager' plays the role a long-lived Bolt pipe used
-- to: one 'DbConn' serves a whole generation run, including the full
-- K-attempt loop under @attempt N K@.
--
-- Why not Bolt: the last maintained Haskell Bolt driver speaks protocol 3.0
-- only, which Neo4j 5 removed — it pinned this project to the EOL Neo4j 4.4.
-- The HTTP endpoint is perf-neutral here (measured ~7.5ms vs ~10ms per
-- generation step on the hottest node, including JSON parsing).
--
-- Rows come back as @Map Text Aeson.Value@ — the same field-keyed shape the
-- old driver produced — so query-site parsing stays a lookup plus a pattern
-- match.

module Harmonic.Database (
    -- * Connection
    DbConn,
    connectNeo4j,
    connectNeo4jAt,

    -- * Running actions
    DbActionT,
    runDb,

    -- * Queries
    runQuery,
    runQueryP,
) where

import           Control.Exception (throwIO)
import           Control.Monad.IO.Class (liftIO)
import           Control.Monad.Reader (ReaderT, ask, runReaderT)
import qualified Data.Aeson as A
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Char8 as BS8
import qualified Data.ByteString.Lazy as BL
import           Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           Network.HTTP.Client
import           System.Environment (lookupEnv)

import           Harmonic.Config (neo4jUri, neo4jUser, neo4jPassword)

-- | An open connection to Neo4j: a keep-alive HTTP manager plus the
-- pre-built request template (endpoint URL and auth header).
data DbConn = DbConn
  { DbConn -> Manager
dcManager :: Manager
  , DbConn -> Request
dcRequest :: Request  -- ^ POST template for the query endpoint
  }

-- | Database actions, threaded over a 'DbConn'. Run with 'runDb'.
-- @ReaderT@ keeps call sites shaped exactly like the old Bolt action monad:
-- query functions compose in the same do-blocks and @liftIO@ works as before.
type DbActionT = ReaderT DbConn IO

-- | Run a database action against a connection.
runDb :: DbConn -> DbActionT a -> IO a
runDb :: forall a. DbConn -> DbActionT a -> IO a
runDb DbConn
conn DbActionT a
action = DbActionT a -> DbConn -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT DbActionT a
action DbConn
conn

-- | Connect to the local Neo4j from "Harmonic.Config" (override with the
-- @HA_NEO4J_URL@ environment variable, e.g. @http:\/\/localhost:7477@ to
-- point a REPL at a scratch container). Probes the server with @RETURN 1@
-- so an unreachable database surfaces the error here, at connect time —
-- matching what every online generation path expects.
connectNeo4j :: IO DbConn
connectNeo4j :: IO DbConn
connectNeo4j = do
  override <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"HA_NEO4J_URL"
  connectNeo4jAt (maybe (T.unpack neo4jUri) id override)

-- | 'connectNeo4j' against an explicit base URL (no trailing slash).
connectNeo4jAt :: String -> IO DbConn
connectNeo4jAt :: [Char] -> IO DbConn
connectNeo4jAt [Char]
base = do
  manager <- ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
  template <- parseUrlThrow (base ++ "/db/neo4j/query/v2")
  let request = Method -> Method -> Request -> Request
applyBasicAuth (Text -> Method
TE.encodeUtf8 Text
neo4jUser) (Text -> Method
TE.encodeUtf8 Text
neo4jPassword)
              (Request -> Request) -> Request -> Request
forall a b. (a -> b) -> a -> b
$ Request
template
                  { method = "POST"
                  , requestHeaders = ("Content-Type", "application/json")
                                   : requestHeaders template
                  }
      conn = Manager -> Request -> DbConn
DbConn Manager
manager Request
request
  _ <- runDb conn (runQuery "RETURN 1")
  pure conn

-- | Run a Cypher query with no parameters.
runQuery :: Text -> DbActionT [Map Text A.Value]
runQuery :: Text -> DbActionT [Map Text Value]
runQuery Text
cypher = Text -> Map Text Value -> DbActionT [Map Text Value]
runQueryP Text
cypher Map Text Value
forall k a. Map k a
Map.empty

-- | Run a Cypher query with parameters. Each result row is keyed by the
-- RETURN field names. Server-side errors (Cypher failures, auth) are thrown
-- as 'IOError's carrying the Neo4j error message.
runQueryP :: Text -> Map Text A.Value -> DbActionT [Map Text A.Value]
runQueryP :: Text -> Map Text Value -> DbActionT [Map Text Value]
runQueryP Text
cypher Map Text Value
params = do
  conn <- ReaderT DbConn IO DbConn
forall r (m :: * -> *). MonadReader r m => m r
ask
  liftIO $ do
    let payload = [Pair] -> Value
A.object
          [ Key
"statement"  Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= Text
cypher
          , Key
"parameters" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= [Pair] -> Value
A.object
              ((Text -> Value -> [Pair] -> [Pair])
-> [Pair] -> Map Text Value -> [Pair]
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey (\Text
k Value
v [Pair]
acc -> (Text -> Key
Key.fromText Text
k Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
A..= Value
v) Pair -> [Pair] -> [Pair]
forall a. a -> [a] -> [a]
: [Pair]
acc) [] Map Text Value
params)
          ]
        request = (DbConn -> Request
dcRequest DbConn
conn)
          { requestBody = RequestBodyLBS (A.encode payload)
          , checkResponse = \Request
_ Response BodyReader
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()  -- surface 4xx bodies ourselves
          }
    response <- httpLbs request (dcManager conn)
    decodeRows (responseBody response)

-- | Parse a query\/v2 response: @{"data": {"fields": [...], "values": [[...]]}}@
-- on success, @{"errors": [{"code", "message"}]}@ on failure.
decodeRows :: BL.ByteString -> IO [Map Text A.Value]
decodeRows :: ByteString -> IO [Map Text Value]
decodeRows ByteString
body =
  case ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
A.decode ByteString
body of
    Maybe Value
Nothing -> Text -> IO [Map Text Value]
forall {a}. Text -> IO a
failWith (Text
"unparseable response: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
preview)
    Just (A.Object Object
o)
      | Just (A.Array Array
errs) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"errors" Object
o
      , Bool -> Bool
not (Array -> Bool
forall a. Vector a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Array
errs) ->
          Text -> IO [Map Text Value]
forall {a}. Text -> IO a
failWith (Text -> [Text] -> Text
T.intercalate Text
"; " ((Value -> Text) -> [Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Text
errText ((Value -> [Value] -> [Value]) -> [Value] -> Array -> [Value]
forall a b. (a -> b -> b) -> b -> Vector a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] Array
errs)))
      | Just (A.Object Object
d) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"data" Object
o
      , Just (A.Array Array
fieldsV) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"fields" Object
d
      , Just (A.Array Array
valuesV) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"values" Object
d ->
          let fields :: [Text]
fields = [ Text
f | A.String Text
f <- (Value -> [Value] -> [Value]) -> [Value] -> Array -> [Value]
forall a b. (a -> b -> b) -> b -> Vector a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] Array
fieldsV ]
              row :: t a -> Map Text a
row t a
vs = [(Text, a)] -> Map Text a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Text] -> [a] -> [(Text, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
fields ((a -> [a] -> [a]) -> [a] -> t a -> [a]
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] t a
vs))
          in [Map Text Value] -> IO [Map Text Value]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ Array -> Map Text Value
forall {t :: * -> *} {a}. Foldable t => t a -> Map Text a
row Array
vs | A.Array Array
vs <- (Value -> [Value] -> [Value]) -> [Value] -> Array -> [Value]
forall a b. (a -> b -> b) -> b -> Vector a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (:) [] Array
valuesV ]
    Maybe Value
_ -> Text -> IO [Map Text Value]
forall {a}. Text -> IO a
failWith (Text
"unexpected response shape: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
preview)
  where
    preview :: Text
preview = Method -> Text
TE.decodeUtf8 (Int -> Method -> Method
BS8.take Int
200 (ByteString -> Method
BL.toStrict ByteString
body))
    errText :: Value -> Text
errText (A.Object Object
e)
      | Just (A.String Text
m) <- Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KM.lookup Key
"message" Object
e = Text
m
    errText Value
v = [Char] -> Text
T.pack (Value -> [Char]
forall a. Show a => a -> [Char]
show Value
v)
    failWith :: Text -> IO a
failWith Text
msg = IOError -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO ([Char] -> IOError
userError ([Char]
"Neo4j query failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
msg))