feat: Implement Lexicon record validation for create/put operations

* PDS index page with ASCII art

PDSharp.Core/Lexicon.fs

···
+namespace PDSharp.Core
+
+open System
+open System.Text.Json
+
+module Lexicon =
+  type LexiconResult =
+    | Ok
+    | Error of string
+
+  module Validation =
+    let private getProperty (p : string) (element : JsonElement) =
+      match element.TryGetProperty(p) with
+      | true, prop -> Some prop
+      | _ -> None
+
+    let private getString (p : string) (element : JsonElement) =
+      match getProperty p element with
+      | Some prop when prop.ValueKind = JsonValueKind.String -> Some(prop.GetString())
+      | _ -> None
+
+    let private validateStringField
+      (element : JsonElement)
+      (fieldName : string)
+      (maxLength : int option)
+      (required : bool)
+      : LexiconResult =
+      match getProperty fieldName element with
+      | Some prop ->
+        if prop.ValueKind <> JsonValueKind.String then
+          Error $"Field '{fieldName}' must be a string"
+        else
+          match maxLength with
+          | Some maxLen when prop.GetString().Length > maxLen ->
+            Error $"Field '{fieldName}' exceeds maximum length of {maxLen}"
+          | _ -> Ok
+      | None ->
+        if required then
+          Error $"Missing required field '{fieldName}'"
+        else
+          Ok
+
+    let private validateIsoDate (element : JsonElement) (fieldName : string) (required : bool) : LexiconResult =
+      match getProperty fieldName element with
+      | Some prop ->
+        if prop.ValueKind <> JsonValueKind.String then
+          Error $"Field '{fieldName}' must be a string"
+        else
+          let s = prop.GetString()
+          let mutable dt = DateTimeOffset.MinValue
+
+          if DateTimeOffset.TryParse(s, &dt) then
+            Ok
+          else
+            Error $"Field '{fieldName}' must be a valid ISO 8601 date string"
+      | None ->
+        if required then
+          Error $"Missing required field '{fieldName}'"
+        else
+          Ok
+
+    let private validateRef (element : JsonElement) (fieldName : string) (required : bool) : LexiconResult =
+      match getProperty fieldName element with
+      | Some prop ->
+        if prop.ValueKind <> JsonValueKind.Object then
+          Error $"Field '{fieldName}' must be an object"
+        else
+          match validateStringField prop "uri" None true, validateStringField prop "cid" None true with
+          | Ok, Ok -> Ok
+          | Error e, _ -> Error $"Field '{fieldName}': {e}"
+          | _, Error e -> Error $"Field '{fieldName}': {e}"
+      | None ->
+        if required then
+          Error $"Missing required field '{fieldName}'"
+        else
+          Ok
+
+    let validatePost (record : JsonElement) : LexiconResult =
+      let textCheck = validateStringField record "text" (Some 3000) true
+      let dateCheck = validateIsoDate record "createdAt" true
+
+      match textCheck, dateCheck with
+      | Ok, Ok -> Ok
+      | Error e, _ -> Error e
+      | _, Error e -> Error e
+
+    let validateLike (record : JsonElement) : LexiconResult =
+      let subjectCheck = validateRef record "subject" true
+      let dateCheck = validateIsoDate record "createdAt" true
+
+      match subjectCheck, dateCheck with
+      | Ok, Ok -> Ok
+      | Error e, _ -> Error e
+      | _, Error e -> Error e
+
+    let validateRepost (record : JsonElement) : LexiconResult =
+      let subjectCheck = validateRef record "subject" true
+      let dateCheck = validateIsoDate record "createdAt" true
+
+      match subjectCheck, dateCheck with
+      | Ok, Ok -> Ok
+      | Error e, _ -> Error e
+      | _, Error e -> Error e
+
+    let validateFollow (record : JsonElement) : LexiconResult =
+      let subjectCheck = validateStringField record "subject" None true
+      let dateCheck = validateIsoDate record "createdAt" true
+
+      match subjectCheck, dateCheck with
+      | Ok, Ok -> Ok
+      | Error e, _ -> Error e
+      | _, Error e -> Error e
+
+    let validateProfile (record : JsonElement) : LexiconResult =
+      let nameCheck = validateStringField record "displayName" (Some 640) false
+      let descCheck = validateStringField record "description" (Some 2560) false
+
+      match nameCheck, descCheck with
+      | Ok, Ok -> Ok
+      | Error e, _ -> Error e
+      | _, Error e -> Error e
+
+  /// Unknown records are valid but unvalidated.
+  let validate (collection : string) (record : JsonElement) : LexiconResult =
+    match collection with
+    | "app.bsky.feed.post" -> Validation.validatePost record
+    | "app.bsky.feed.like" -> Validation.validateLike record
+    | "app.bsky.feed.repost" -> Validation.validateRepost record
+    | "app.bsky.graph.follow" -> Validation.validateFollow record
+    | "app.bsky.actor.profile" -> Validation.validateProfile record
+    | _ -> Ok

PDSharp.Core/PDSharp.Core.fsproj

···
         <Compile Include="Auth.fs" />
         <Compile Include="Firehose.fs" />
         <Compile Include="DidResolver.fs" />
+        <Compile Include="Lexicon.fs" />
         <Compile Include="Library.fs" />
     </ItemGroup>
 

PDSharp.Tests/Conformance.Tests.fs

···
+module PDSharp.Tests.Conformance
+
+open Xunit
+open System
+open System.Text.Json
+open PDSharp.Core
+
+module LexiconTests =
+
+  let parse (json : string) =
+    JsonSerializer.Deserialize<JsonElement>(json)
+
+  [<Fact>]
+  let ``Valid Post passes validation`` () =
+    let json =
+      """{
+            "$type": "app.bsky.feed.post",
+            "text": "Hello, world!",
+            "createdAt": "2023-10-27T10:00:00Z"
+        }"""
+
+    let element = parse json
+    let result = Lexicon.validate "app.bsky.feed.post" element
+    Assert.Equal(Lexicon.Ok, result)
+
+  [<Fact>]
+  let ``Post missing text fails validation`` () =
+    let json =
+      """{
+            "$type": "app.bsky.feed.post",
+            "createdAt": "2023-10-27T10:00:00Z"
+        }"""
+
+    let element = parse json
+    let result = Lexicon.validate "app.bsky.feed.post" element
+
+    match result with
+    | Lexicon.Error msg -> Assert.Contains("text", msg)
+    | _ -> Assert.Fail("Should have failed validation")
+
+  [<Fact>]
+  let ``Post text too long passes validation`` () =
+    let longText = String('a', 3001)
+
+    let template =
+      """{
+            "$type": "app.bsky.feed.post",
+            "text": "TEXT_PLACEHOLDER",
+            "createdAt": "2023-10-27T10:00:00Z"
+        }"""
+
+    let json = template.Replace("TEXT_PLACEHOLDER", longText)
+    let element = parse json
+    let result = Lexicon.validate "app.bsky.feed.post" element
+
+    match result with
+    | Lexicon.Error msg -> Assert.Contains("exceeds maximum length", msg)
+    | _ -> Assert.Fail("Should have failed validation")
+
+  [<Fact>]
+  let ``Valid Like passes validation`` () =
+    let json =
+      """{
+            "$type": "app.bsky.feed.like",
+            "subject": {
+                "uri": "at://did:plc:123/app.bsky.feed.post/3k5",
+                "cid": "bafyreih..."
+            },
+            "createdAt": "2023-10-27T10:00:00Z"
+        }"""
+
+    let element = parse json
+    let result = Lexicon.validate "app.bsky.feed.like" element
+    Assert.Equal(Lexicon.Ok, result)
+
+  [<Fact>]
+  let ``Like missing subject fails validation`` () =
+    let json =
+      """{
+            "$type": "app.bsky.feed.like",
+            "createdAt": "2023-10-27T10:00:00Z"
+        }"""
+
+    let element = parse json
+    let result = Lexicon.validate "app.bsky.feed.like" element
+
+    match result with
+    | Lexicon.Error msg -> Assert.Contains("subject", msg)
+    | _ -> Assert.Fail("Should have failed validation")
+
+  [<Fact>]
+  let ``Like subject missing uri passes validation (should fail)`` () =
+    let json =
+      """{
+            "$type": "app.bsky.feed.like",
+            "subject": {
+                "cid": "bafyreih..."
+            },
+            "createdAt": "2023-10-27T10:00:00Z"
+        }"""
+
+    let element = parse json
+    let result = Lexicon.validate "app.bsky.feed.like" element
+
+    match result with
+    | Lexicon.Error msg -> Assert.Contains("uri", msg)
+    | _ -> Assert.Fail("Should have failed validation")
+
+  [<Fact>]
+  let ``Valid Profile passes validation`` () =
+    let json =
+      """{
+            "$type": "app.bsky.actor.profile",
+            "displayName": "Alice",
+            "description": "Bob's friend"
+        }"""
+
+    let element = parse json
+    let result = Lexicon.validate "app.bsky.actor.profile" element
+    Assert.Equal(Lexicon.Ok, result)
+
+  [<Fact>]
+  let ``Profile description check length`` () =
+    let longDesc = String('a', 2561)
+
+    let template =
+      """{
+            "$type": "app.bsky.actor.profile",
+            "description": "DESC_PLACEHOLDER"
+        }"""
+
+    let json = template.Replace("DESC_PLACEHOLDER", longDesc)
+    let element = parse json
+    let result = Lexicon.validate "app.bsky.actor.profile" element
+
+    match result with
+    | Lexicon.Error msg -> Assert.Contains("exceeds maximum length", msg)
+    | _ -> Assert.Fail("Should have failed validation")
+
+  [<Fact>]
+  let ``Unknown type validation is lax`` () =
+    let json = """{ "random": "stuff" }"""
+    let element = parse json
+    let result = Lexicon.validate "com.unknown.record" element
+    Assert.Equal(Lexicon.Ok, result)

PDSharp.Tests/PDSharp.Tests.fsproj

···
     <Compile Include="Car.Tests.fs" />
     <Compile Include="Firehose.Tests.fs" />
     <Compile Include="Auth.Tests.fs" />
+    <Compile Include="Conformance.Tests.fs" />
     <Compile Include="Program.fs" />
   </ItemGroup>
 

PDSharp/Program.fs

···
 open System
-open System.IO
 open System.Text
 open System.Text.Json
 open Microsoft.AspNetCore.Builder
···
       let request =
         JsonSerializer.Deserialize<CreateRecordRequest>(body, JsonSerializerOptions(PropertyNameCaseInsensitive = true))
 
-      let did = request.repo
+      match Lexicon.validate request.collection request.record with
+      | Lexicon.Error msg ->
+        ctx.SetStatusCode 400
+        return! json { error = "InvalidRequest"; message = msg } next ctx
+      | Lexicon.Ok ->
+        let did = request.repo
 
-      let rkey =
-        match request.rkey with
-        | Some r when not (String.IsNullOrWhiteSpace(r)) -> r
-        | _ -> Tid.generate ()
+        let rkey =
+          match request.rkey with
+          | Some r when not (String.IsNullOrWhiteSpace(r)) -> r
+          | _ -> Tid.generate ()
 
-      let recordJson = request.record.GetRawText()
-      let recordBytes = Encoding.UTF8.GetBytes(recordJson)
-      let! recordCid = (blockStore :> IBlockStore).Put(recordBytes)
+        let recordJson = request.record.GetRawText()
+        let recordBytes = Encoding.UTF8.GetBytes(recordJson)
+        let! recordCid = (blockStore :> IBlockStore).Put(recordBytes)
 
-      let repoData = Map.tryFind did repos |> Option.defaultValue emptyRepo
-      let mstKey = $"{request.collection}/{rkey}"
+        let repoData = Map.tryFind did repos |> Option.defaultValue emptyRepo
+        let mstKey = $"{request.collection}/{rkey}"
 
-      let! newMstRoot = Mst.put loader persister repoData.MstRoot mstKey recordCid ""
-      let! mstRootCid = persister newMstRoot
+        let! newMstRoot = Mst.put loader persister repoData.MstRoot mstKey recordCid ""
+        let! mstRootCid = persister newMstRoot
 
-      let newRev = Tid.generate ()
-      let! (_, commitCid) = signAndStoreCommit did mstRootCid newRev repoData.Head
+        let newRev = Tid.generate ()
+        let! (_, commitCid) = signAndStoreCommit did mstRootCid newRev repoData.Head
 
-      let collectionMap =
-        Map.tryFind request.collection repoData.Collections
-        |> Option.defaultValue Map.empty
+        let collectionMap =
+          Map.tryFind request.collection repoData.Collections
+          |> Option.defaultValue Map.empty
 
-      let newCollectionMap = Map.add rkey recordCid collectionMap
+        let newCollectionMap = Map.add rkey recordCid collectionMap
 
-      let newCollections =
-        Map.add request.collection newCollectionMap repoData.Collections
+        let newCollections =
+          Map.add request.collection newCollectionMap repoData.Collections
 
-      let updatedRepo = {
-        MstRoot = newMstRoot
-        Collections = newCollections
-        Rev = newRev
-        Head = Some commitCid
-        Prev = repoData.Head
-      }
+        let updatedRepo = {
+          MstRoot = newMstRoot
+          Collections = newCollections
+          Rev = newRev
+          Head = Some commitCid
+          Prev = repoData.Head
+        }
 
-      repos <- Map.add did updatedRepo repos
+        repos <- Map.add did updatedRepo repos
 
-      let! allBlocks = (blockStore :> IBlockStore).GetAllCidsAndData()
-      let carBytes = Car.createCar [ commitCid ] allBlocks
-      let event = createCommitEvent did newRev commitCid carBytes
-      broadcastEvent event
+        let! allBlocks = (blockStore :> IBlockStore).GetAllCidsAndData()
+        let carBytes = Car.createCar [ commitCid ] allBlocks
+        let event = createCommitEvent did newRev commitCid carBytes
+        broadcastEvent event
 
-      let uri = $"at://{did}/{request.collection}/{rkey}"
-      ctx.SetStatusCode 200
+        let uri = $"at://{did}/{request.collection}/{rkey}"
+        ctx.SetStatusCode 200
 
-      return!
-        json
-          {|
-            uri = uri
-            cid = recordCid.ToString()
-            commit = {| rev = newRev; cid = commitCid.ToString() |}
-          |}
-          next
-          ctx
+        return!
+          json
+            {|
+              uri = uri
+              cid = recordCid.ToString()
+              commit = {| rev = newRev; cid = commitCid.ToString() |}
+            |}
+            next
+            ctx
     }
 
   let getRecordHandler : HttpHandler =
···
       let request =
         JsonSerializer.Deserialize<CreateRecordRequest>(body, JsonSerializerOptions(PropertyNameCaseInsensitive = true))
 
-      match request.rkey with
-      | Some r when not (String.IsNullOrWhiteSpace r) ->
-        let did = request.repo
-        let recordJson = request.record.GetRawText()
-        let recordBytes = Encoding.UTF8.GetBytes(recordJson)
-        let! recordCid = (blockStore :> IBlockStore).Put(recordBytes)
+      match Lexicon.validate request.collection request.record with
+      | Lexicon.Error msg ->
+        ctx.SetStatusCode 400
+        return! json { error = "InvalidRequest"; message = msg } next ctx
+      | Lexicon.Ok ->
+        match request.rkey with
+        | Some r when not (String.IsNullOrWhiteSpace r) ->
+          let did = request.repo
+          let recordJson = request.record.GetRawText()
+          let recordBytes = Encoding.UTF8.GetBytes(recordJson)
+          let! recordCid = (blockStore :> IBlockStore).Put(recordBytes)
 
-        let repoData = Map.tryFind did repos |> Option.defaultValue emptyRepo
-        let mstKey = $"{request.collection}/{r}"
+          let repoData = Map.tryFind did repos |> Option.defaultValue emptyRepo
+          let mstKey = $"{request.collection}/{r}"
 
-        let! newMstRoot = Mst.put loader persister repoData.MstRoot mstKey recordCid ""
-        let! mstRootCid = persister newMstRoot
+          let! newMstRoot = Mst.put loader persister repoData.MstRoot mstKey recordCid ""
+          let! mstRootCid = persister newMstRoot
 
-        let newRev = Tid.generate ()
-        let! (_, commitCid) = signAndStoreCommit did mstRootCid newRev repoData.Head
+          let newRev = Tid.generate ()
+          let! (_, commitCid) = signAndStoreCommit did mstRootCid newRev repoData.Head
 
-        let collectionMap =
-          Map.tryFind request.collection repoData.Collections
-          |> Option.defaultValue Map.empty
+          let collectionMap =
+            Map.tryFind request.collection repoData.Collections
+            |> Option.defaultValue Map.empty
 
-        let newCollectionMap = Map.add r recordCid collectionMap
+          let newCollectionMap = Map.add r recordCid collectionMap
 
-        let newCollections =
-          Map.add request.collection newCollectionMap repoData.Collections
+          let newCollections =
+            Map.add request.collection newCollectionMap repoData.Collections
 
-        let updatedRepo = {
-          MstRoot = newMstRoot
-          Collections = newCollections
-          Rev = newRev
-          Head = Some commitCid
-          Prev = repoData.Head
-        }
+          let updatedRepo = {
+            MstRoot = newMstRoot
+            Collections = newCollections
+            Rev = newRev
+            Head = Some commitCid
+            Prev = repoData.Head
+          }
 
-        repos <- Map.add did updatedRepo repos
+          repos <- Map.add did updatedRepo repos
 
-        let! allBlocks = (blockStore :> IBlockStore).GetAllCidsAndData()
-        let carBytes = Car.createCar [ commitCid ] allBlocks
-        let event = createCommitEvent did newRev commitCid carBytes
-        broadcastEvent event
+          let! allBlocks = (blockStore :> IBlockStore).GetAllCidsAndData()
+          let carBytes = Car.createCar [ commitCid ] allBlocks
+          let event = createCommitEvent did newRev commitCid carBytes
+          broadcastEvent event
 
-        ctx.SetStatusCode 200
+          ctx.SetStatusCode 200
 
-        return!
-          json
-            {|
-              uri = $"at://{did}/{request.collection}/{r}"
-              cid = recordCid.ToString()
-              commit = {| rev = newRev; cid = commitCid.ToString() |}
-            |}
-            next
-            ctx
-      | _ ->
-        ctx.SetStatusCode 400
+          return!
+            json
+              {|
+                uri = $"at://{did}/{request.collection}/{r}"
+                cid = recordCid.ToString()
+                commit = {| rev = newRev; cid = commitCid.ToString() |}
+              |}
+              next
+              ctx
+        | _ ->
+          ctx.SetStatusCode 400
 
-        return!
-          json
-            {
-              error = "InvalidRequest"
-              message = "rkey is required for putRecord"
-            }
-            next
-            ctx
+          return!
+            json
+              {
+                error = "InvalidRequest"
+                message = "rkey is required for putRecord"
+              }
+              next
+              ctx
     }
 
   /// sync.getRepo: Export entire repository as CAR file
···
             ctx
     }
 
+  let indexHandler : HttpHandler =
+    fun next ctx ->
+      let html =
+        """<html>
+      <head><title>PDSharp</title></head>
+      <body>
+        <pre>
+         888                             888                         8888888888   888  888
+         888                             888                         888          888  888
+         888                             888                         888        888888888888
+ 8888b.  888888 88888b.  888d888 .d88b.  888888 .d88b.       88      8888888      888  888
+    "88b 888    888 "88b 888P"  d88""88b 888   d88""88b    888888    888          888  888
+.d888888 888    888  888 888    888  888 888   888  888      88      888        888888888888
+888  888 Y88b.  888 d88P 888    Y88..88P Y88b. Y88..88P              888          888  888
+"Y888888  "Y888 88888P"  888     "Y88P"   "Y888 "Y88P"               888          888  888
+                888
+                888
+                888
+
+
+This is an AT Protocol Personal Data Server (aka, an atproto PDS)
+
+Most API routes are under /xrpc/
+
+      Code: https://github.com/bluesky-social/atproto
+            https://github.com/stormlightlabs/PDSharp
+            https://tangled.org/desertthunder.dev/PDSharp
+ Self-Host: https://github.com/bluesky-social/pds
+  Protocol: https://atproto.com
+        </pre>
+      </body>
+    </html>"""
+
+      ctx.SetContentType "text/html"
+      ctx.SetStatusCode 200
+      ctx.WriteStringAsync html
+
   let webApp =
     choose [
       GET
-      >=> route "/xrpc/com.atproto.server.describeServer"
-      >=> describeServerHandler
+      >=> choose [
+        route "/" >=> indexHandler
+        route "/xrpc/com.atproto.server.describeServer" >=> describeServerHandler
+      ]
       POST >=> route "/xrpc/com.atproto.server.createAccount" >=> createAccountHandler
       POST >=> route "/xrpc/com.atproto.server.createSession" >=> createSessionHandler
       POST

roadmap.txt

···
 --------------------------------------------------------------------------------
 Milestone I: Lexicon Validation + Conformance
 --------------------------------------------------------------------------------
-- Lexicon validation for writes (app.bsky.* records)
-- Conformance testing: diff CIDs/CARs/signatures vs reference PDS
+- [x] Lexicon validation for writes (app.bsky.* records)
+- [x] Conformance testing: diff CIDs/CARs/signatures vs reference PDS
 DoD: Same inputs → same outputs for repo/sync surfaces
 --------------------------------------------------------------------------------
-Milestone J: Persistence + Backups (Self-hosted PDS)
+Milestone J: Persistence + Backups
 --------------------------------------------------------------------------------
 Deliverables:
   - BackupOps module in Core (scheduler unit / cron / scripts, plus Litestream config)
···
 - Upload blob, verify retrieval via sync.getBlob
 DoD: Posts appear in clients, media loads reliably
 --------------------------------------------------------------------------------
-Milestone O: Account Migration (Optional)
+Milestone O: Account Migration
 --------------------------------------------------------------------------------
 - Export/import from bsky.social
 - Update DID service endpoint