diff --git a/.gitignore b/.gitignore index 0338461..4f494d9 100644 --- a/.gitignore +++ b/.gitignore @@ -1,79 +1,5 @@ -# SPDX-License-Identifier: AGPL-3.0-or-later -# RSR-compliant .gitignore - -# OS & Editor -.DS_Store -Thumbs.db -*.swp -*.swo -*~ -.idea/ -.vscode/ - -# Build -/target/ -/_build/ -/build/ -/dist/ -/out/ - -# Dependencies -/node_modules/ -/vendor/ -/deps/ -/.elixir_ls/ - -# Rust -# Cargo.lock # Keep for binaries - -# Elixir -/cover/ -/doc/ -*.ez -erl_crash.dump - -# Julia -*.jl.cov -*.jl.mem -/Manifest.toml - -# ReScript -/lib/bs/ -/.bsb.lock - -# Python (SaltStack only) -__pycache__/ -*.py[cod] -.venv/ - -# Ada/SPARK -*.ali -/obj/ -/bin/ - -# Haskell -/.stack-work/ -/dist-newstyle/ - -# Chapel -*.chpl.tmp.* - -# Secrets -.env -.env.* -*.pem -*.key -secrets/ - -# Test/Coverage -/coverage/ -htmlcov/ - -# Logs -*.log -/logs/ - -# Temp -/tmp/ -*.tmp -*.bak +lib/ +node_modules/ +.bsb.lock +*.res.js +.merlin diff --git a/LICENCE b/LICENCE new file mode 100644 index 0000000..9fe8841 --- /dev/null +++ b/LICENCE @@ -0,0 +1,17 @@ +GNU AFFERO GENERAL PUBLIC LICENSE +Version 3, 19 November 2007 + +Copyright (C) 2025 Hyperpolymath + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU Affero General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Affero General Public License for more details. + +You should have received a copy of the GNU Affero General Public License +along with this program. If not, see . diff --git a/README.adoc b/README.adoc index 8b13789..164265a 100644 --- a/README.adoc +++ b/README.adoc @@ -1 +1,185 @@ +// SPDX-License-Identifier: AGPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Hyperpolymath += rescript-poly-core +:toc: +:toc-placement: preamble +:icons: font + +**Shared foundation library for the Hyperpolymath ReScript ecosystem.** + +Part of the https://github.com/hyperpolymath/rescript-full-stack[ReScript Full Stack] ecosystem. + +== Features + +* **Core utilities** - Result extensions, async helpers, structured logging, config loading +* **MCP infrastructure** - Protocol types, server builder, tool registration +* **Reusable patterns** - Common abstractions used across poly-* projects +* **Zero external dependencies** - Only requires @rescript/core + +== Installation + +[source,bash] +---- +deno add jsr:@hyperpolymath/rescript-poly-core +---- + +== Modules + +=== Core.Result + +Extended Result type utilities for error handling. + +[source,rescript] +---- +open PolyCore + +// Chain results +let result = Ok(42) + ->Result.map(x => x * 2) + ->Result.flatMap(x => if x > 50 { Ok(x) } else { Error("Too small") }) + +// Collect all or fail +let results = Result.all([Ok(1), Ok(2), Ok(3)]) // Ok([1, 2, 3]) + +// Try/catch to Result +let parsed = Result.tryCatch( + () => JSON.parseExn(input), + _ => "Invalid JSON" +) +---- + +=== Core.Async + +Promise utilities for async operations. + +[source,rescript] +---- +open PolyCore + +// Sleep +await Async.sleep(1000) + +// Timeout +let result = await Async.timeout(5000, fetchData()) + +// Retry with exponential backoff +let data = await Async.retry( + ~config={maxAttempts: 3, initialDelayMs: 1000, maxDelayMs: 30000, backoffMultiplier: 2.0}, + () => fetchUnreliableApi() +) + +// Parallel with concurrency limit +let results = await Async.parallelLimit(~concurrency=5, tasks) + +// Debounce/throttle +let debouncedSave = Async.debounce(500, data => save(data)) +---- + +=== Core.Logger + +Structured JSON logging. + +[source,rescript] +---- +open PolyCore + +let logger = Logger.make(~config={ + minLevel: Logger.Debug, + json: true, + timestamps: true, + context: Dict.fromArray([("service", "my-app")]), +}) + +logger->Logger.info("Server started", ~extra=Dict.fromArray([ + ("port", JSON.Encode.int(8080)), +])) + +// Child logger with additional context +let reqLogger = logger->Logger.child(Dict.fromArray([ + ("requestId", "abc123"), +])) +---- + +=== Core.Config + +Configuration loading from environment. + +[source,rescript] +---- +open PolyCore + +let config = Config.fromEnv(~prefix="APP_") + +let port = config->Config.getIntOr("PORT", 3000) +let debug = config->Config.getBoolOr("DEBUG", false) +let dbUrl = config->Config.getString("DATABASE_URL") // throws if missing +---- + +=== MCP.Protocol + +MCP protocol types and builders. + +[source,rescript] +---- +open PolyCore.MCP + +// Build tool results +let result = Protocol.success("Operation completed") +let jsonResult = Protocol.successJson({"count": 42}) +let errorResult = Protocol.error("Something went wrong") + +// Build schemas +let schema = Protocol.objectSchema( + ~properties=Dict.fromArray([ + ("name", Protocol.stringProp(~description="The user's name")), + ("age", Protocol.numberProp(~description="Age in years")), + ]), + ~required=["name"], +) + +// Parse arguments +let name = Protocol.requireArg(args, "name") +let limit = Protocol.getIntArg(args, "limit")->Option.getOr(10) +---- + +=== MCP.Server + +MCP server builder. + +[source,rescript] +---- +open PolyCore.MCP + +let server = Server.make(~name="my-mcp", ~version="1.0.0") + ->Server.registerTool( + { + name: "greet", + description: "Greet a user", + inputSchema: Protocol.objectSchema( + ~properties=Dict.fromArray([ + ("name", Protocol.stringProp(~description="Name to greet")), + ]), + ~required=["name"], + ), + }, + async args => { + switch Protocol.requireArg(args, "name") { + | Ok(name) => Protocol.success(`Hello, ${name}!`) + | Error(e) => Protocol.error(e) + } + }, + ) + +// Handle incoming requests +let response = await server->Server.handleRequest("tools/call", Some(params)) +---- + +== Related + +* https://github.com/hyperpolymath/rescript-full-stack[rescript-full-stack] - Full ecosystem overview +* https://github.com/hyperpolymath/poly-mcps[poly-mcps] - MCP servers using this library + +== Licence + +AGPL-3.0-or-later diff --git a/deno.json b/deno.json new file mode 100644 index 0000000..6dbce66 --- /dev/null +++ b/deno.json @@ -0,0 +1,14 @@ +{ + "name": "@hyperpolymath/rescript-poly-core", + "version": "0.1.0", + "exports": "./src/PolyCore.res.js", + "tasks": { + "build": "rescript build", + "clean": "rescript clean", + "dev": "rescript build -w", + "test": "deno test --allow-all tests/" + }, + "compilerOptions": { + "lib": ["deno.ns", "deno.unstable"] + } +} diff --git a/rescript.json b/rescript.json new file mode 100644 index 0000000..67a2ffe --- /dev/null +++ b/rescript.json @@ -0,0 +1,22 @@ +{ + "name": "@hyperpolymath/rescript-poly-core", + "sources": [ + { + "dir": "src", + "subdirs": true + } + ], + "package-specs": [ + { + "module": "esmodule", + "in-source": true + } + ], + "suffix": ".res.js", + "bs-dependencies": [ + "@rescript/core" + ], + "bsc-flags": [ + "-open RescriptCore" + ] +} diff --git a/src/Core/Async.res b/src/Core/Async.res new file mode 100644 index 0000000..2f35aa8 --- /dev/null +++ b/src/Core/Async.res @@ -0,0 +1,178 @@ +// SPDX-License-Identifier: AGPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Hyperpolymath + +@@uncurried + +/** + * Async/Promise utilities for ReScript. + */ + +/** Sleep for a given number of milliseconds */ +let sleep = (ms: int): promise => { + Promise.make((resolve, _reject) => { + let _ = setTimeout(() => resolve(), ms) + }) +} + +/** Timeout a promise after ms milliseconds */ +exception Timeout(string) + +let timeout = async (ms: int, promise: promise<'a>): 'a => { + let timeoutPromise = Promise.make((_, reject) => { + let _ = setTimeout(() => reject(Timeout(`Operation timed out after ${Int.toString(ms)}ms`)), ms) + }) + await Promise.race([promise, timeoutPromise]) +} + +/** Retry configuration */ +type retryConfig = { + maxAttempts: int, + initialDelayMs: int, + maxDelayMs: int, + backoffMultiplier: float, +} + +let defaultRetryConfig: retryConfig = { + maxAttempts: 3, + initialDelayMs: 1000, + maxDelayMs: 30000, + backoffMultiplier: 2.0, +} + +/** Retry a promise-returning function with exponential backoff */ +let retry = async ( + ~config: retryConfig=defaultRetryConfig, + fn: unit => promise<'a>, +): 'a => { + let rec attempt = async (attemptNum: int, delay: int) => { + try { + await fn() + } catch { + | e => + if attemptNum >= config.maxAttempts { + raise(e) + } else { + await sleep(delay) + let nextDelay = Int.min( + Float.toInt(Int.toFloat(delay) *. config.backoffMultiplier), + config.maxDelayMs, + ) + await attempt(attemptNum + 1, nextDelay) + } + } + } + await attempt(1, config.initialDelayMs) +} + +/** Run promises in parallel with concurrency limit */ +let parallelLimit = async ( + ~concurrency: int, + tasks: array promise<'a>>, +): array<'a> => { + let results: array<'a> = [] + let running = ref(0) + let index = ref(0) + let total = tasks->Array.length + + await Promise.make((resolve, reject) => { + let rec runNext = () => { + while running.contents < concurrency && index.contents < total { + let currentIndex = index.contents + index := index.contents + 1 + running := running.contents + 1 + + let task = tasks->Array.getUnsafe(currentIndex) + let _ = task()->Promise.thenResolve(result => { + results->Array.push(result)->ignore + running := running.contents - 1 + if results->Array.length == total { + resolve(results) + } else { + runNext() + } + })->Promise.catch(e => { + reject(e) + Promise.resolve() + }) + } + } + if total == 0 { + resolve([]) + } else { + runNext() + } + }) +} + +/** Run promises sequentially */ +let sequential = async (tasks: array promise<'a>>): array<'a> => { + let results: array<'a> = [] + for i in 0 to tasks->Array.length - 1 { + let task = tasks->Array.getUnsafe(i) + let result = await task() + results->Array.push(result)->ignore + } + results +} + +/** Map over array with async function */ +let mapAsync = async (arr: array<'a>, fn: 'a => promise<'b>): array<'b> => { + let results: array<'b> = [] + for i in 0 to arr->Array.length - 1 { + let item = arr->Array.getUnsafe(i) + let result = await fn(item) + results->Array.push(result)->ignore + } + results +} + +/** Filter array with async predicate */ +let filterAsync = async (arr: array<'a>, predicate: 'a => promise): array<'a> => { + let results: array<'a> = [] + for i in 0 to arr->Array.length - 1 { + let item = arr->Array.getUnsafe(i) + let keep = await predicate(item) + if keep { + results->Array.push(item)->ignore + } + } + results +} + +/** Debounce a function */ +type debounced<'a> = { + call: 'a => unit, + cancel: unit => unit, +} + +let debounce = (delayMs: int, fn: 'a => unit): debounced<'a> => { + let timeoutId = ref(None) + { + call: arg => { + switch timeoutId.contents { + | Some(id) => clearTimeout(id) + | None => () + } + timeoutId := Some(setTimeout(() => fn(arg), delayMs)) + }, + cancel: () => { + switch timeoutId.contents { + | Some(id) => clearTimeout(id) + | None => () + } + timeoutId := None + }, + } +} + +/** Throttle a function */ +let throttle = (limitMs: int, fn: 'a => unit): ('a => unit) => { + let lastRun = ref(0.0) + arg => { + let now = Date.now() + if now -. lastRun.contents >= Int.toFloat(limitMs) { + lastRun := now + fn(arg) + } + } +} diff --git a/src/Core/Config.res b/src/Core/Config.res new file mode 100644 index 0000000..f891825 --- /dev/null +++ b/src/Core/Config.res @@ -0,0 +1,186 @@ +// SPDX-License-Identifier: AGPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Hyperpolymath + +@@uncurried + +/** + * Configuration loading and validation utilities. + */ + +/** Configuration source */ +type source = + | Env + | File(string) + | Object(Dict.t) + +/** Configuration error */ +type configError = + | MissingKey(string) + | InvalidType(string, string) + | ValidationFailed(string, string) + +exception ConfigError(configError) + +/** Convert error to string */ +let errorToString = (error: configError): string => { + switch error { + | MissingKey(key) => `Missing required configuration key: ${key}` + | InvalidType(key, expected) => `Invalid type for key '${key}': expected ${expected}` + | ValidationFailed(key, reason) => `Validation failed for key '${key}': ${reason}` + } +} + +/** Configuration builder */ +type t = { + data: Dict.t, + prefix: string, +} + +/** Create config from environment variables */ +let fromEnv = (~prefix: string=""): t => { + // Get all env vars (Deno) + @val @scope(("Deno", "env")) external toObject: unit => Dict.t = "toObject" + + let envVars = try { + toObject() + } catch { + | _ => Dict.make() + } + + let data = Dict.make() + envVars->Dict.forEachWithKey((value, key) => { + let shouldInclude = prefix == "" || key->String.startsWith(prefix) + if shouldInclude { + let normalizedKey = if prefix != "" { + key->String.sliceToEnd(~start=String.length(prefix)) + } else { + key + } + data->Dict.set(normalizedKey, JSON.Encode.string(value)) + } + }) + + {data, prefix} +} + +/** Create config from JSON object */ +let fromObject = (obj: Dict.t): t => { + {data: obj, prefix: ""} +} + +/** Get a required string */ +let getString = (config: t, key: string): string => { + switch config.data->Dict.get(key) { + | Some(JSON.String(s)) => s + | Some(_) => raise(ConfigError(InvalidType(key, "string"))) + | None => raise(ConfigError(MissingKey(key))) + } +} + +/** Get an optional string */ +let getStringOpt = (config: t, key: string): option => { + switch config.data->Dict.get(key) { + | Some(JSON.String(s)) => Some(s) + | _ => None + } +} + +/** Get a string with default */ +let getStringOr = (config: t, key: string, default: string): string => { + getStringOpt(config, key)->Option.getOr(default) +} + +/** Get a required int */ +let getInt = (config: t, key: string): int => { + switch config.data->Dict.get(key) { + | Some(JSON.Number(n)) => Float.toInt(n) + | Some(JSON.String(s)) => + switch Int.fromString(s, ~radix=10) { + | Some(i) => i + | None => raise(ConfigError(InvalidType(key, "int"))) + } + | Some(_) => raise(ConfigError(InvalidType(key, "int"))) + | None => raise(ConfigError(MissingKey(key))) + } +} + +/** Get an optional int */ +let getIntOpt = (config: t, key: string): option => { + switch config.data->Dict.get(key) { + | Some(JSON.Number(n)) => Some(Float.toInt(n)) + | Some(JSON.String(s)) => Int.fromString(s, ~radix=10) + | _ => None + } +} + +/** Get an int with default */ +let getIntOr = (config: t, key: string, default: int): int => { + getIntOpt(config, key)->Option.getOr(default) +} + +/** Get a required bool */ +let getBool = (config: t, key: string): bool => { + switch config.data->Dict.get(key) { + | Some(JSON.Boolean(b)) => b + | Some(JSON.String("true" | "1" | "yes")) => true + | Some(JSON.String("false" | "0" | "no")) => false + | Some(_) => raise(ConfigError(InvalidType(key, "bool"))) + | None => raise(ConfigError(MissingKey(key))) + } +} + +/** Get an optional bool */ +let getBoolOpt = (config: t, key: string): option => { + switch config.data->Dict.get(key) { + | Some(JSON.Boolean(b)) => Some(b) + | Some(JSON.String("true" | "1" | "yes")) => Some(true) + | Some(JSON.String("false" | "0" | "no")) => Some(false) + | _ => None + } +} + +/** Get a bool with default */ +let getBoolOr = (config: t, key: string, default: bool): bool => { + getBoolOpt(config, key)->Option.getOr(default) +} + +/** Get a required float */ +let getFloat = (config: t, key: string): float => { + switch config.data->Dict.get(key) { + | Some(JSON.Number(n)) => n + | Some(JSON.String(s)) => + switch Float.fromString(s) { + | Some(f) => f + | None => raise(ConfigError(InvalidType(key, "float"))) + } + | Some(_) => raise(ConfigError(InvalidType(key, "float"))) + | None => raise(ConfigError(MissingKey(key))) + } +} + +/** Get an optional float */ +let getFloatOpt = (config: t, key: string): option => { + switch config.data->Dict.get(key) { + | Some(JSON.Number(n)) => Some(n) + | Some(JSON.String(s)) => Float.fromString(s) + | _ => None + } +} + +/** Merge two configs (second takes precedence) */ +let merge = (base: t, override: t): t => { + let merged = Dict.make() + base.data->Dict.forEachWithKey((v, k) => merged->Dict.set(k, v)) + override.data->Dict.forEachWithKey((v, k) => merged->Dict.set(k, v)) + {data: merged, prefix: base.prefix} +} + +/** Check if a key exists */ +let has = (config: t, key: string): bool => { + config.data->Dict.get(key)->Option.isSome +} + +/** Get all keys */ +let keys = (config: t): array => { + config.data->Dict.keysToArray +} diff --git a/src/Core/Logger.res b/src/Core/Logger.res new file mode 100644 index 0000000..49f29c1 --- /dev/null +++ b/src/Core/Logger.res @@ -0,0 +1,133 @@ +// SPDX-License-Identifier: AGPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Hyperpolymath + +@@uncurried + +/** + * Structured logging for ReScript applications. + */ + +/** Log levels */ +type level = + | Debug + | Info + | Warn + | Error + +/** Convert level to string */ +let levelToString = (level: level): string => { + switch level { + | Debug => "debug" + | Info => "info" + | Warn => "warn" + | Error => "error" + } +} + +/** Convert level to numeric priority */ +let levelToPriority = (level: level): int => { + switch level { + | Debug => 0 + | Info => 1 + | Warn => 2 + | Error => 3 + } +} + +/** Logger configuration */ +type config = { + minLevel: level, + json: bool, + timestamps: bool, + context: Dict.t, +} + +let defaultConfig: config = { + minLevel: Info, + json: true, + timestamps: true, + context: Dict.make(), +} + +/** A logger instance */ +type t = { + config: config, + log: (level, string, option>) => unit, +} + +/** Create a new logger */ +let make = (~config: config=defaultConfig): t => { + let log = (level: level, message: string, extra: option>) => { + if levelToPriority(level) >= levelToPriority(config.minLevel) { + if config.json { + let entry = Dict.make() + entry->Dict.set("level", JSON.Encode.string(levelToString(level))) + entry->Dict.set("message", JSON.Encode.string(message)) + + if config.timestamps { + entry->Dict.set("timestamp", JSON.Encode.string(Date.make()->Date.toISOString)) + } + + // Add context + config.context->Dict.forEachWithKey((value, key) => { + entry->Dict.set(key, JSON.Encode.string(value)) + }) + + // Add extra fields + switch extra { + | Some(fields) => + fields->Dict.forEachWithKey((value, key) => { + entry->Dict.set(key, value) + }) + | None => () + } + + Console.log(JSON.stringify(JSON.Encode.object(entry))) + } else { + let timestamp = config.timestamps ? `[${Date.make()->Date.toISOString}] ` : "" + let levelStr = `[${levelToString(level)->String.toUpperCase}]` + Console.log(`${timestamp}${levelStr} ${message}`) + + switch extra { + | Some(fields) if fields->Dict.keysToArray->Array.length > 0 => + Console.log(JSON.stringify(JSON.Encode.object(fields))) + | _ => () + } + } + } + } + + {config, log} +} + +/** Log at debug level */ +let debug = (logger: t, message: string, ~extra: Dict.t=Dict.make()): unit => { + logger.log(Debug, message, Some(extra)) +} + +/** Log at info level */ +let info = (logger: t, message: string, ~extra: Dict.t=Dict.make()): unit => { + logger.log(Info, message, Some(extra)) +} + +/** Log at warn level */ +let warn = (logger: t, message: string, ~extra: Dict.t=Dict.make()): unit => { + logger.log(Warn, message, Some(extra)) +} + +/** Log at error level */ +let error = (logger: t, message: string, ~extra: Dict.t=Dict.make()): unit => { + logger.log(Error, message, Some(extra)) +} + +/** Create a child logger with additional context */ +let child = (logger: t, context: Dict.t): t => { + let newContext = Dict.make() + logger.config.context->Dict.forEachWithKey((v, k) => newContext->Dict.set(k, v)) + context->Dict.forEachWithKey((v, k) => newContext->Dict.set(k, v)) + + make(~config={...logger.config, context: newContext}) +} + +/** Global default logger */ +let defaultLogger = make() diff --git a/src/Core/Result.res b/src/Core/Result.res new file mode 100644 index 0000000..6122dc4 --- /dev/null +++ b/src/Core/Result.res @@ -0,0 +1,138 @@ +// SPDX-License-Identifier: AGPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Hyperpolymath + +@@uncurried + +/** + * Extended Result utilities for error handling. + */ + +/** Map over the Ok value */ +let map = (result: result<'a, 'e>, fn: 'a => 'b): result<'b, 'e> => { + switch result { + | Ok(value) => Ok(fn(value)) + | Error(err) => Error(err) + } +} + +/** Map over the Error value */ +let mapError = (result: result<'a, 'e>, fn: 'e => 'f): result<'a, 'f> => { + switch result { + | Ok(value) => Ok(value) + | Error(err) => Error(fn(err)) + } +} + +/** Flat map (bind) for chaining Results */ +let flatMap = (result: result<'a, 'e>, fn: 'a => result<'b, 'e>): result<'b, 'e> => { + switch result { + | Ok(value) => fn(value) + | Error(err) => Error(err) + } +} + +/** Get the Ok value or a default */ +let getOr = (result: result<'a, 'e>, default: 'a): 'a => { + switch result { + | Ok(value) => value + | Error(_) => default + } +} + +/** Get the Ok value or compute a default from the error */ +let getOrElse = (result: result<'a, 'e>, fn: 'e => 'a): 'a => { + switch result { + | Ok(value) => value + | Error(err) => fn(err) + } +} + +/** Convert Option to Result */ +let fromOption = (opt: option<'a>, error: 'e): result<'a, 'e> => { + switch opt { + | Some(value) => Ok(value) + | None => Error(error) + } +} + +/** Convert Result to Option (discarding error) */ +let toOption = (result: result<'a, 'e>): option<'a> => { + switch result { + | Ok(value) => Some(value) + | Error(_) => None + } +} + +/** Check if Result is Ok */ +let isOk = (result: result<'a, 'e>): bool => { + switch result { + | Ok(_) => true + | Error(_) => false + } +} + +/** Check if Result is Error */ +let isError = (result: result<'a, 'e>): bool => { + switch result { + | Ok(_) => false + | Error(_) => true + } +} + +/** Combine two Results - both must be Ok */ +let both = (r1: result<'a, 'e>, r2: result<'b, 'e>): result<('a, 'b), 'e> => { + switch (r1, r2) { + | (Ok(a), Ok(b)) => Ok((a, b)) + | (Error(e), _) => Error(e) + | (_, Error(e)) => Error(e) + } +} + +/** Collect an array of Results into a Result of array */ +let all = (results: array>): result, 'e> => { + results->Array.reduce(Ok([]), (acc, result) => { + switch (acc, result) { + | (Ok(arr), Ok(value)) => Ok(arr->Array.concat([value])) + | (Error(e), _) => Error(e) + | (_, Error(e)) => Error(e) + } + }) +} + +/** Try a function that might throw, returning Result */ +let tryCatch = (fn: unit => 'a, onError: exn => 'e): result<'a, 'e> => { + try { + Ok(fn()) + } catch { + | e => Error(onError(e)) + } +} + +/** Async version of tryCatch */ +let tryCatchAsync = async (fn: unit => promise<'a>, onError: exn => 'e): result<'a, 'e> => { + try { + Ok(await fn()) + } catch { + | e => Error(onError(e)) + } +} + +/** Tap into Ok value without changing it */ +let tap = (result: result<'a, 'e>, fn: 'a => unit): result<'a, 'e> => { + switch result { + | Ok(value) => + fn(value) + Ok(value) + | Error(err) => Error(err) + } +} + +/** Tap into Error value without changing it */ +let tapError = (result: result<'a, 'e>, fn: 'e => unit): result<'a, 'e> => { + switch result { + | Ok(value) => Ok(value) + | Error(err) => + fn(err) + Error(err) + } +} diff --git a/src/MCP/Protocol.res b/src/MCP/Protocol.res new file mode 100644 index 0000000..340eb62 --- /dev/null +++ b/src/MCP/Protocol.res @@ -0,0 +1,208 @@ +// SPDX-License-Identifier: AGPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Hyperpolymath + +@@uncurried + +/** + * MCP (Model Context Protocol) types and utilities. + * Provides common infrastructure for building MCP servers. + */ + +/** Content types for tool results */ +type contentType = + | Text + | Image + | Resource + +/** A single content item in a tool result */ +type content = { + @as("type") type_: string, + text?: string, + data?: string, + mimeType?: string, +} + +/** Result of a tool invocation */ +type toolResult = { + content: array, + isError?: bool, +} + +/** Tool input schema (JSON Schema) */ +type inputSchema = { + @as("type") type_: string, + properties?: Dict.t, + required?: array, +} + +/** A tool definition */ +type tool = { + name: string, + description: string, + inputSchema: inputSchema, +} + +/** Resource definition */ +type resource = { + uri: string, + name: string, + description?: string, + mimeType?: string, +} + +/** Prompt argument */ +type promptArgument = { + name: string, + description?: string, + required?: bool, +} + +/** Prompt definition */ +type prompt = { + name: string, + description?: string, + arguments?: array, +} + +// Result builders + +/** Create a successful text result */ +let success = (text: string): toolResult => { + {content: [{type_: "text", text}]} +} + +/** Create a successful JSON result */ +let successJson = (data: JSON.t): toolResult => { + {content: [{type_: "text", text: JSON.stringify(data)}]} +} + +/** Create an error result */ +let error = (message: string): toolResult => { + {content: [{type_: "text", text: message}], isError: true} +} + +/** Create a multi-content result */ +let multi = (items: array): toolResult => { + {content: items} +} + +/** Create a text content item */ +let text = (value: string): content => { + {type_: "text", text: value} +} + +/** Create an image content item */ +let image = (base64Data: string, mimeType: string): content => { + {type_: "image", data: base64Data, mimeType} +} + +// Schema builders + +/** Create an object schema */ +let objectSchema = ( + ~properties: Dict.t, + ~required: array=[], +): inputSchema => { + { + type_: "object", + properties, + required, + } +} + +/** Create a string property schema */ +let stringProp = (~description: string=""): JSON.t => { + let obj = Dict.make() + obj->Dict.set("type", JSON.Encode.string("string")) + if description != "" { + obj->Dict.set("description", JSON.Encode.string(description)) + } + JSON.Encode.object(obj) +} + +/** Create a number property schema */ +let numberProp = (~description: string=""): JSON.t => { + let obj = Dict.make() + obj->Dict.set("type", JSON.Encode.string("number")) + if description != "" { + obj->Dict.set("description", JSON.Encode.string(description)) + } + JSON.Encode.object(obj) +} + +/** Create a boolean property schema */ +let boolProp = (~description: string=""): JSON.t => { + let obj = Dict.make() + obj->Dict.set("type", JSON.Encode.string("boolean")) + if description != "" { + obj->Dict.set("description", JSON.Encode.string(description)) + } + JSON.Encode.object(obj) +} + +/** Create an array property schema */ +let arrayProp = (~items: JSON.t, ~description: string=""): JSON.t => { + let obj = Dict.make() + obj->Dict.set("type", JSON.Encode.string("array")) + obj->Dict.set("items", items) + if description != "" { + obj->Dict.set("description", JSON.Encode.string(description)) + } + JSON.Encode.object(obj) +} + +/** Create an enum property schema */ +let enumProp = (~values: array, ~description: string=""): JSON.t => { + let obj = Dict.make() + obj->Dict.set("type", JSON.Encode.string("string")) + obj->Dict.set("enum", JSON.Encode.array(values, JSON.Encode.string)) + if description != "" { + obj->Dict.set("description", JSON.Encode.string(description)) + } + JSON.Encode.object(obj) +} + +// Argument parsing helpers + +/** Get a required string argument */ +let getArg = (args: Dict.t, name: string): option => { + switch args->Dict.get(name) { + | Some(JSON.String(s)) => Some(s) + | _ => None + } +} + +/** Get a required string argument or error */ +let requireArg = (args: Dict.t, name: string): result => { + switch getArg(args, name) { + | Some(s) => Ok(s) + | None => Error(`Missing required argument: ${name}`) + } +} + +/** Get an optional int argument */ +let getIntArg = (args: Dict.t, name: string): option => { + switch args->Dict.get(name) { + | Some(JSON.Number(n)) => Some(Float.toInt(n)) + | Some(JSON.String(s)) => Int.fromString(s, ~radix=10) + | _ => None + } +} + +/** Get an optional bool argument */ +let getBoolArg = (args: Dict.t, name: string): option => { + switch args->Dict.get(name) { + | Some(JSON.Boolean(b)) => Some(b) + | Some(JSON.String("true")) => Some(true) + | Some(JSON.String("false")) => Some(false) + | _ => None + } +} + +/** Get an optional array argument */ +let getArrayArg = (args: Dict.t, name: string): option> => { + switch args->Dict.get(name) { + | Some(JSON.Array(arr)) => Some(arr) + | _ => None + } +} diff --git a/src/MCP/Server.res b/src/MCP/Server.res new file mode 100644 index 0000000..eca3baf --- /dev/null +++ b/src/MCP/Server.res @@ -0,0 +1,201 @@ +// SPDX-License-Identifier: AGPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Hyperpolymath + +@@uncurried + +/** + * MCP Server infrastructure for building MCP servers. + */ + +open Protocol + +/** Server info */ +type serverInfo = { + name: string, + version: string, +} + +/** Server capabilities */ +type capabilities = { + tools?: bool, + resources?: bool, + prompts?: bool, +} + +/** Tool handler function */ +type toolHandler = Dict.t => promise + +/** Registered tool with handler */ +type registeredTool = { + definition: tool, + handler: toolHandler, +} + +/** MCP Server state */ +type t = { + info: serverInfo, + capabilities: capabilities, + tools: Dict.t, + resources: Dict.t, + prompts: Dict.t, +} + +/** Create a new MCP server */ +let make = (~name: string, ~version: string): t => { + { + info: {name, version}, + capabilities: {tools: true, resources: false, prompts: false}, + tools: Dict.make(), + resources: Dict.make(), + prompts: Dict.make(), + } +} + +/** Register a tool */ +let registerTool = (server: t, definition: tool, handler: toolHandler): t => { + server.tools->Dict.set(definition.name, {definition, handler}) + {...server, capabilities: {...server.capabilities, tools: true}} +} + +/** Register a resource */ +let registerResource = (server: t, resource: resource): t => { + server.resources->Dict.set(resource.uri, resource) + {...server, capabilities: {...server.capabilities, resources: true}} +} + +/** Register a prompt */ +let registerPrompt = (server: t, prompt: prompt): t => { + server.prompts->Dict.set(prompt.name, prompt) + {...server, capabilities: {...server.capabilities, prompts: true}} +} + +/** Get list of tools */ +let listTools = (server: t): array => { + server.tools->Dict.valuesToArray->Array.map(rt => rt.definition) +} + +/** Get list of resources */ +let listResources = (server: t): array => { + server.resources->Dict.valuesToArray +} + +/** Get list of prompts */ +let listPrompts = (server: t): array => { + server.prompts->Dict.valuesToArray +} + +/** Call a tool by name */ +let callTool = async (server: t, name: string, args: Dict.t): toolResult => { + switch server.tools->Dict.get(name) { + | Some(registeredTool) => + try { + await registeredTool.handler(args) + } catch { + | Exn.Error(e) => + let message = Exn.message(e)->Option.getOr("Unknown error") + error(`Tool '${name}' failed: ${message}`) + | _ => error(`Tool '${name}' failed with unknown error`) + } + | None => error(`Unknown tool: ${name}`) + } +} + +/** Handle MCP JSON-RPC request */ +let handleRequest = async (server: t, method: string, params: option): JSON.t => { + switch method { + | "initialize" => + let response = Dict.make() + response->Dict.set("protocolVersion", JSON.Encode.string("2024-11-05")) + + let serverInfo = Dict.make() + serverInfo->Dict.set("name", JSON.Encode.string(server.info.name)) + serverInfo->Dict.set("version", JSON.Encode.string(server.info.version)) + response->Dict.set("serverInfo", JSON.Encode.object(serverInfo)) + + let caps = Dict.make() + if server.capabilities.tools->Option.getOr(false) { + caps->Dict.set("tools", JSON.Encode.object(Dict.make())) + } + if server.capabilities.resources->Option.getOr(false) { + caps->Dict.set("resources", JSON.Encode.object(Dict.make())) + } + if server.capabilities.prompts->Option.getOr(false) { + caps->Dict.set("prompts", JSON.Encode.object(Dict.make())) + } + response->Dict.set("capabilities", JSON.Encode.object(caps)) + + JSON.Encode.object(response) + + | "tools/list" => + let tools = listTools(server)->Array.map(t => { + let obj = Dict.make() + obj->Dict.set("name", JSON.Encode.string(t.name)) + obj->Dict.set("description", JSON.Encode.string(t.description)) + + let schema = Dict.make() + schema->Dict.set("type", JSON.Encode.string(t.inputSchema.type_)) + switch t.inputSchema.properties { + | Some(props) => schema->Dict.set("properties", JSON.Encode.object(props)) + | None => () + } + switch t.inputSchema.required { + | Some(req) => schema->Dict.set("required", JSON.Encode.array(req, JSON.Encode.string)) + | None => () + } + obj->Dict.set("inputSchema", JSON.Encode.object(schema)) + + JSON.Encode.object(obj) + }) + + let response = Dict.make() + response->Dict.set("tools", JSON.Encode.array(tools, x => x)) + JSON.Encode.object(response) + + | "tools/call" => + let (name, args) = switch params { + | Some(JSON.Object(p)) => + let n = switch p->Dict.get("name") { + | Some(JSON.String(s)) => s + | _ => "" + } + let a = switch p->Dict.get("arguments") { + | Some(JSON.Object(o)) => o + | _ => Dict.make() + } + (n, a) + | _ => ("", Dict.make()) + } + + let result = await callTool(server, name, args) + + let response = Dict.make() + let contentArr = result.content->Array.map(c => { + let obj = Dict.make() + obj->Dict.set("type", JSON.Encode.string(c.type_)) + switch c.text { + | Some(t) => obj->Dict.set("text", JSON.Encode.string(t)) + | None => () + } + switch c.data { + | Some(d) => obj->Dict.set("data", JSON.Encode.string(d)) + | None => () + } + switch c.mimeType { + | Some(m) => obj->Dict.set("mimeType", JSON.Encode.string(m)) + | None => () + } + JSON.Encode.object(obj) + }) + response->Dict.set("content", JSON.Encode.array(contentArr, x => x)) + switch result.isError { + | Some(true) => response->Dict.set("isError", JSON.Encode.bool(true)) + | _ => () + } + JSON.Encode.object(response) + + | _ => + let err = Dict.make() + err->Dict.set("error", JSON.Encode.string(`Unknown method: ${method}`)) + JSON.Encode.object(err) + } +} diff --git a/src/PolyCore.res b/src/PolyCore.res new file mode 100644 index 0000000..1627ec3 --- /dev/null +++ b/src/PolyCore.res @@ -0,0 +1,21 @@ +// SPDX-License-Identifier: AGPL-3.0-or-later +// SPDX-FileCopyrightText: 2025 Hyperpolymath + +/** + * PolyCore - Shared foundation library for the Hyperpolymath ReScript ecosystem. + * + * Provides common utilities, patterns, and infrastructure for building + * ReScript applications and MCP servers. + */ + +// Re-export core modules +module Result = Core.Result +module Async = Core.Async +module Logger = Core.Logger +module Config = Core.Config + +// Re-export MCP modules +module MCP = { + module Protocol = MCP.Protocol + module Server = MCP.Server +}