desertthunder.dev
+131
PDSharp.Core/Lexicon.fs
+131
PDSharp.Core/Lexicon.fs
···
1
+
namespace PDSharp.Core
2
+
3
+
open System
4
+
open System.Text.Json
5
+
6
+
module Lexicon =
7
+
type LexiconResult =
8
+
| Ok
9
+
| Error of string
10
+
11
+
module Validation =
12
+
let private getProperty (p : string) (element : JsonElement) =
13
+
match element.TryGetProperty(p) with
14
+
| true, prop -> Some prop
15
+
| _ -> None
16
+
17
+
let private getString (p : string) (element : JsonElement) =
18
+
match getProperty p element with
19
+
| Some prop when prop.ValueKind = JsonValueKind.String -> Some(prop.GetString())
20
+
| _ -> None
21
+
22
+
let private validateStringField
23
+
(element : JsonElement)
24
+
(fieldName : string)
25
+
(maxLength : int option)
26
+
(required : bool)
27
+
: LexiconResult =
28
+
match getProperty fieldName element with
29
+
| Some prop ->
30
+
if prop.ValueKind <> JsonValueKind.String then
31
+
Error $"Field '{fieldName}' must be a string"
32
+
else
33
+
match maxLength with
34
+
| Some maxLen when prop.GetString().Length > maxLen ->
35
+
Error $"Field '{fieldName}' exceeds maximum length of {maxLen}"
36
+
| _ -> Ok
37
+
| None ->
38
+
if required then
39
+
Error $"Missing required field '{fieldName}'"
40
+
else
41
+
Ok
42
+
43
+
let private validateIsoDate (element : JsonElement) (fieldName : string) (required : bool) : LexiconResult =
44
+
match getProperty fieldName element with
45
+
| Some prop ->
46
+
if prop.ValueKind <> JsonValueKind.String then
47
+
Error $"Field '{fieldName}' must be a string"
48
+
else
49
+
let s = prop.GetString()
50
+
let mutable dt = DateTimeOffset.MinValue
51
+
52
+
if DateTimeOffset.TryParse(s, &dt) then
53
+
Ok
54
+
else
55
+
Error $"Field '{fieldName}' must be a valid ISO 8601 date string"
56
+
| None ->
57
+
if required then
58
+
Error $"Missing required field '{fieldName}'"
59
+
else
60
+
Ok
61
+
62
+
let private validateRef (element : JsonElement) (fieldName : string) (required : bool) : LexiconResult =
63
+
match getProperty fieldName element with
64
+
| Some prop ->
65
+
if prop.ValueKind <> JsonValueKind.Object then
66
+
Error $"Field '{fieldName}' must be an object"
67
+
else
68
+
match validateStringField prop "uri" None true, validateStringField prop "cid" None true with
69
+
| Ok, Ok -> Ok
70
+
| Error e, _ -> Error $"Field '{fieldName}': {e}"
71
+
| _, Error e -> Error $"Field '{fieldName}': {e}"
72
+
| None ->
73
+
if required then
74
+
Error $"Missing required field '{fieldName}'"
75
+
else
76
+
Ok
77
+
78
+
let validatePost (record : JsonElement) : LexiconResult =
79
+
let textCheck = validateStringField record "text" (Some 3000) true
80
+
let dateCheck = validateIsoDate record "createdAt" true
81
+
82
+
match textCheck, dateCheck with
83
+
| Ok, Ok -> Ok
84
+
| Error e, _ -> Error e
85
+
| _, Error e -> Error e
86
+
87
+
let validateLike (record : JsonElement) : LexiconResult =
88
+
let subjectCheck = validateRef record "subject" true
89
+
let dateCheck = validateIsoDate record "createdAt" true
90
+
91
+
match subjectCheck, dateCheck with
92
+
| Ok, Ok -> Ok
93
+
| Error e, _ -> Error e
94
+
| _, Error e -> Error e
95
+
96
+
let validateRepost (record : JsonElement) : LexiconResult =
97
+
let subjectCheck = validateRef record "subject" true
98
+
let dateCheck = validateIsoDate record "createdAt" true
99
+
100
+
match subjectCheck, dateCheck with
101
+
| Ok, Ok -> Ok
102
+
| Error e, _ -> Error e
103
+
| _, Error e -> Error e
104
+
105
+
let validateFollow (record : JsonElement) : LexiconResult =
106
+
let subjectCheck = validateStringField record "subject" None true
107
+
let dateCheck = validateIsoDate record "createdAt" true
108
+
109
+
match subjectCheck, dateCheck with
110
+
| Ok, Ok -> Ok
111
+
| Error e, _ -> Error e
112
+
| _, Error e -> Error e
113
+
114
+
let validateProfile (record : JsonElement) : LexiconResult =
115
+
let nameCheck = validateStringField record "displayName" (Some 640) false
116
+
let descCheck = validateStringField record "description" (Some 2560) false
117
+
118
+
match nameCheck, descCheck with
119
+
| Ok, Ok -> Ok
120
+
| Error e, _ -> Error e
121
+
| _, Error e -> Error e
122
+
123
+
/// Unknown records are valid but unvalidated.
124
+
let validate (collection : string) (record : JsonElement) : LexiconResult =
125
+
match collection with
126
+
| "app.bsky.feed.post" -> Validation.validatePost record
127
+
| "app.bsky.feed.like" -> Validation.validateLike record
128
+
| "app.bsky.feed.repost" -> Validation.validateRepost record
129
+
| "app.bsky.graph.follow" -> Validation.validateFollow record
130
+
| "app.bsky.actor.profile" -> Validation.validateProfile record
131
+
| _ -> Ok
+1
PDSharp.Core/PDSharp.Core.fsproj
+1
PDSharp.Core/PDSharp.Core.fsproj
+145
PDSharp.Tests/Conformance.Tests.fs
+145
PDSharp.Tests/Conformance.Tests.fs
···
1
+
module PDSharp.Tests.Conformance
2
+
3
+
open Xunit
4
+
open System
5
+
open System.Text.Json
6
+
open PDSharp.Core
7
+
8
+
module LexiconTests =
9
+
10
+
let parse (json : string) =
11
+
JsonSerializer.Deserialize<JsonElement>(json)
12
+
13
+
[<Fact>]
14
+
let ``Valid Post passes validation`` () =
15
+
let json =
16
+
"""{
17
+
"$type": "app.bsky.feed.post",
18
+
"text": "Hello, world!",
19
+
"createdAt": "2023-10-27T10:00:00Z"
20
+
}"""
21
+
22
+
let element = parse json
23
+
let result = Lexicon.validate "app.bsky.feed.post" element
24
+
Assert.Equal(Lexicon.Ok, result)
25
+
26
+
[<Fact>]
27
+
let ``Post missing text fails validation`` () =
28
+
let json =
29
+
"""{
30
+
"$type": "app.bsky.feed.post",
31
+
"createdAt": "2023-10-27T10:00:00Z"
32
+
}"""
33
+
34
+
let element = parse json
35
+
let result = Lexicon.validate "app.bsky.feed.post" element
36
+
37
+
match result with
38
+
| Lexicon.Error msg -> Assert.Contains("text", msg)
39
+
| _ -> Assert.Fail("Should have failed validation")
40
+
41
+
[<Fact>]
42
+
let ``Post text too long passes validation`` () =
43
+
let longText = String('a', 3001)
44
+
45
+
let template =
46
+
"""{
47
+
"$type": "app.bsky.feed.post",
48
+
"text": "TEXT_PLACEHOLDER",
49
+
"createdAt": "2023-10-27T10:00:00Z"
50
+
}"""
51
+
52
+
let json = template.Replace("TEXT_PLACEHOLDER", longText)
53
+
let element = parse json
54
+
let result = Lexicon.validate "app.bsky.feed.post" element
55
+
56
+
match result with
57
+
| Lexicon.Error msg -> Assert.Contains("exceeds maximum length", msg)
58
+
| _ -> Assert.Fail("Should have failed validation")
59
+
60
+
[<Fact>]
61
+
let ``Valid Like passes validation`` () =
62
+
let json =
63
+
"""{
64
+
"$type": "app.bsky.feed.like",
65
+
"subject": {
66
+
"uri": "at://did:plc:123/app.bsky.feed.post/3k5",
67
+
"cid": "bafyreih..."
68
+
},
69
+
"createdAt": "2023-10-27T10:00:00Z"
70
+
}"""
71
+
72
+
let element = parse json
73
+
let result = Lexicon.validate "app.bsky.feed.like" element
74
+
Assert.Equal(Lexicon.Ok, result)
75
+
76
+
[<Fact>]
77
+
let ``Like missing subject fails validation`` () =
78
+
let json =
79
+
"""{
80
+
"$type": "app.bsky.feed.like",
81
+
"createdAt": "2023-10-27T10:00:00Z"
82
+
}"""
83
+
84
+
let element = parse json
85
+
let result = Lexicon.validate "app.bsky.feed.like" element
86
+
87
+
match result with
88
+
| Lexicon.Error msg -> Assert.Contains("subject", msg)
89
+
| _ -> Assert.Fail("Should have failed validation")
90
+
91
+
[<Fact>]
92
+
let ``Like subject missing uri passes validation (should fail)`` () =
93
+
let json =
94
+
"""{
95
+
"$type": "app.bsky.feed.like",
96
+
"subject": {
97
+
"cid": "bafyreih..."
98
+
},
99
+
"createdAt": "2023-10-27T10:00:00Z"
100
+
}"""
101
+
102
+
let element = parse json
103
+
let result = Lexicon.validate "app.bsky.feed.like" element
104
+
105
+
match result with
106
+
| Lexicon.Error msg -> Assert.Contains("uri", msg)
107
+
| _ -> Assert.Fail("Should have failed validation")
108
+
109
+
[<Fact>]
110
+
let ``Valid Profile passes validation`` () =
111
+
let json =
112
+
"""{
113
+
"$type": "app.bsky.actor.profile",
114
+
"displayName": "Alice",
115
+
"description": "Bob's friend"
116
+
}"""
117
+
118
+
let element = parse json
119
+
let result = Lexicon.validate "app.bsky.actor.profile" element
120
+
Assert.Equal(Lexicon.Ok, result)
121
+
122
+
[<Fact>]
123
+
let ``Profile description check length`` () =
124
+
let longDesc = String('a', 2561)
125
+
126
+
let template =
127
+
"""{
128
+
"$type": "app.bsky.actor.profile",
129
+
"description": "DESC_PLACEHOLDER"
130
+
}"""
131
+
132
+
let json = template.Replace("DESC_PLACEHOLDER", longDesc)
133
+
let element = parse json
134
+
let result = Lexicon.validate "app.bsky.actor.profile" element
135
+
136
+
match result with
137
+
| Lexicon.Error msg -> Assert.Contains("exceeds maximum length", msg)
138
+
| _ -> Assert.Fail("Should have failed validation")
139
+
140
+
[<Fact>]
141
+
let ``Unknown type validation is lax`` () =
142
+
let json = """{ "random": "stuff" }"""
143
+
let element = parse json
144
+
let result = Lexicon.validate "com.unknown.record" element
145
+
Assert.Equal(Lexicon.Ok, result)
+1
PDSharp.Tests/PDSharp.Tests.fsproj
+1
PDSharp.Tests/PDSharp.Tests.fsproj
+144
-96
PDSharp/Program.fs
+144
-96
PDSharp/Program.fs
···
1
1
open System
2
-
open System.IO
3
2
open System.Text
4
3
open System.Text.Json
5
4
open Microsoft.AspNetCore.Builder
···
355
354
let request =
356
355
JsonSerializer.Deserialize<CreateRecordRequest>(body, JsonSerializerOptions(PropertyNameCaseInsensitive = true))
357
356
358
-
let did = request.repo
357
+
match Lexicon.validate request.collection request.record with
358
+
| Lexicon.Error msg ->
359
+
ctx.SetStatusCode 400
360
+
return! json { error = "InvalidRequest"; message = msg } next ctx
361
+
| Lexicon.Ok ->
362
+
let did = request.repo
359
363
360
-
let rkey =
361
-
match request.rkey with
362
-
| Some r when not (String.IsNullOrWhiteSpace(r)) -> r
363
-
| _ -> Tid.generate ()
364
+
let rkey =
365
+
match request.rkey with
366
+
| Some r when not (String.IsNullOrWhiteSpace(r)) -> r
367
+
| _ -> Tid.generate ()
364
368
365
-
let recordJson = request.record.GetRawText()
366
-
let recordBytes = Encoding.UTF8.GetBytes(recordJson)
367
-
let! recordCid = (blockStore :> IBlockStore).Put(recordBytes)
369
+
let recordJson = request.record.GetRawText()
370
+
let recordBytes = Encoding.UTF8.GetBytes(recordJson)
371
+
let! recordCid = (blockStore :> IBlockStore).Put(recordBytes)
368
372
369
-
let repoData = Map.tryFind did repos |> Option.defaultValue emptyRepo
370
-
let mstKey = $"{request.collection}/{rkey}"
373
+
let repoData = Map.tryFind did repos |> Option.defaultValue emptyRepo
374
+
let mstKey = $"{request.collection}/{rkey}"
371
375
372
-
let! newMstRoot = Mst.put loader persister repoData.MstRoot mstKey recordCid ""
373
-
let! mstRootCid = persister newMstRoot
376
+
let! newMstRoot = Mst.put loader persister repoData.MstRoot mstKey recordCid ""
377
+
let! mstRootCid = persister newMstRoot
374
378
375
-
let newRev = Tid.generate ()
376
-
let! (_, commitCid) = signAndStoreCommit did mstRootCid newRev repoData.Head
379
+
let newRev = Tid.generate ()
380
+
let! (_, commitCid) = signAndStoreCommit did mstRootCid newRev repoData.Head
377
381
378
-
let collectionMap =
379
-
Map.tryFind request.collection repoData.Collections
380
-
|> Option.defaultValue Map.empty
382
+
let collectionMap =
383
+
Map.tryFind request.collection repoData.Collections
384
+
|> Option.defaultValue Map.empty
381
385
382
-
let newCollectionMap = Map.add rkey recordCid collectionMap
386
+
let newCollectionMap = Map.add rkey recordCid collectionMap
383
387
384
-
let newCollections =
385
-
Map.add request.collection newCollectionMap repoData.Collections
388
+
let newCollections =
389
+
Map.add request.collection newCollectionMap repoData.Collections
386
390
387
-
let updatedRepo = {
388
-
MstRoot = newMstRoot
389
-
Collections = newCollections
390
-
Rev = newRev
391
-
Head = Some commitCid
392
-
Prev = repoData.Head
393
-
}
391
+
let updatedRepo = {
392
+
MstRoot = newMstRoot
393
+
Collections = newCollections
394
+
Rev = newRev
395
+
Head = Some commitCid
396
+
Prev = repoData.Head
397
+
}
394
398
395
-
repos <- Map.add did updatedRepo repos
399
+
repos <- Map.add did updatedRepo repos
396
400
397
-
let! allBlocks = (blockStore :> IBlockStore).GetAllCidsAndData()
398
-
let carBytes = Car.createCar [ commitCid ] allBlocks
399
-
let event = createCommitEvent did newRev commitCid carBytes
400
-
broadcastEvent event
401
+
let! allBlocks = (blockStore :> IBlockStore).GetAllCidsAndData()
402
+
let carBytes = Car.createCar [ commitCid ] allBlocks
403
+
let event = createCommitEvent did newRev commitCid carBytes
404
+
broadcastEvent event
401
405
402
-
let uri = $"at://{did}/{request.collection}/{rkey}"
403
-
ctx.SetStatusCode 200
406
+
let uri = $"at://{did}/{request.collection}/{rkey}"
407
+
ctx.SetStatusCode 200
404
408
405
-
return!
406
-
json
407
-
{|
408
-
uri = uri
409
-
cid = recordCid.ToString()
410
-
commit = {| rev = newRev; cid = commitCid.ToString() |}
411
-
|}
412
-
next
413
-
ctx
409
+
return!
410
+
json
411
+
{|
412
+
uri = uri
413
+
cid = recordCid.ToString()
414
+
commit = {| rev = newRev; cid = commitCid.ToString() |}
415
+
|}
416
+
next
417
+
ctx
414
418
}
415
419
416
420
let getRecordHandler : HttpHandler =
···
512
516
let request =
513
517
JsonSerializer.Deserialize<CreateRecordRequest>(body, JsonSerializerOptions(PropertyNameCaseInsensitive = true))
514
518
515
-
match request.rkey with
516
-
| Some r when not (String.IsNullOrWhiteSpace r) ->
517
-
let did = request.repo
518
-
let recordJson = request.record.GetRawText()
519
-
let recordBytes = Encoding.UTF8.GetBytes(recordJson)
520
-
let! recordCid = (blockStore :> IBlockStore).Put(recordBytes)
519
+
match Lexicon.validate request.collection request.record with
520
+
| Lexicon.Error msg ->
521
+
ctx.SetStatusCode 400
522
+
return! json { error = "InvalidRequest"; message = msg } next ctx
523
+
| Lexicon.Ok ->
524
+
match request.rkey with
525
+
| Some r when not (String.IsNullOrWhiteSpace r) ->
526
+
let did = request.repo
527
+
let recordJson = request.record.GetRawText()
528
+
let recordBytes = Encoding.UTF8.GetBytes(recordJson)
529
+
let! recordCid = (blockStore :> IBlockStore).Put(recordBytes)
521
530
522
-
let repoData = Map.tryFind did repos |> Option.defaultValue emptyRepo
523
-
let mstKey = $"{request.collection}/{r}"
531
+
let repoData = Map.tryFind did repos |> Option.defaultValue emptyRepo
532
+
let mstKey = $"{request.collection}/{r}"
524
533
525
-
let! newMstRoot = Mst.put loader persister repoData.MstRoot mstKey recordCid ""
526
-
let! mstRootCid = persister newMstRoot
534
+
let! newMstRoot = Mst.put loader persister repoData.MstRoot mstKey recordCid ""
535
+
let! mstRootCid = persister newMstRoot
527
536
528
-
let newRev = Tid.generate ()
529
-
let! (_, commitCid) = signAndStoreCommit did mstRootCid newRev repoData.Head
537
+
let newRev = Tid.generate ()
538
+
let! (_, commitCid) = signAndStoreCommit did mstRootCid newRev repoData.Head
530
539
531
-
let collectionMap =
532
-
Map.tryFind request.collection repoData.Collections
533
-
|> Option.defaultValue Map.empty
540
+
let collectionMap =
541
+
Map.tryFind request.collection repoData.Collections
542
+
|> Option.defaultValue Map.empty
534
543
535
-
let newCollectionMap = Map.add r recordCid collectionMap
544
+
let newCollectionMap = Map.add r recordCid collectionMap
536
545
537
-
let newCollections =
538
-
Map.add request.collection newCollectionMap repoData.Collections
546
+
let newCollections =
547
+
Map.add request.collection newCollectionMap repoData.Collections
539
548
540
-
let updatedRepo = {
541
-
MstRoot = newMstRoot
542
-
Collections = newCollections
543
-
Rev = newRev
544
-
Head = Some commitCid
545
-
Prev = repoData.Head
546
-
}
549
+
let updatedRepo = {
550
+
MstRoot = newMstRoot
551
+
Collections = newCollections
552
+
Rev = newRev
553
+
Head = Some commitCid
554
+
Prev = repoData.Head
555
+
}
547
556
548
-
repos <- Map.add did updatedRepo repos
557
+
repos <- Map.add did updatedRepo repos
549
558
550
-
let! allBlocks = (blockStore :> IBlockStore).GetAllCidsAndData()
551
-
let carBytes = Car.createCar [ commitCid ] allBlocks
552
-
let event = createCommitEvent did newRev commitCid carBytes
553
-
broadcastEvent event
559
+
let! allBlocks = (blockStore :> IBlockStore).GetAllCidsAndData()
560
+
let carBytes = Car.createCar [ commitCid ] allBlocks
561
+
let event = createCommitEvent did newRev commitCid carBytes
562
+
broadcastEvent event
554
563
555
-
ctx.SetStatusCode 200
564
+
ctx.SetStatusCode 200
556
565
557
-
return!
558
-
json
559
-
{|
560
-
uri = $"at://{did}/{request.collection}/{r}"
561
-
cid = recordCid.ToString()
562
-
commit = {| rev = newRev; cid = commitCid.ToString() |}
563
-
|}
564
-
next
565
-
ctx
566
-
| _ ->
567
-
ctx.SetStatusCode 400
566
+
return!
567
+
json
568
+
{|
569
+
uri = $"at://{did}/{request.collection}/{r}"
570
+
cid = recordCid.ToString()
571
+
commit = {| rev = newRev; cid = commitCid.ToString() |}
572
+
|}
573
+
next
574
+
ctx
575
+
| _ ->
576
+
ctx.SetStatusCode 400
568
577
569
-
return!
570
-
json
571
-
{
572
-
error = "InvalidRequest"
573
-
message = "rkey is required for putRecord"
574
-
}
575
-
next
576
-
ctx
578
+
return!
579
+
json
580
+
{
581
+
error = "InvalidRequest"
582
+
message = "rkey is required for putRecord"
583
+
}
584
+
next
585
+
ctx
577
586
}
578
587
579
588
/// sync.getRepo: Export entire repository as CAR file
···
793
802
ctx
794
803
}
795
804
805
+
let indexHandler : HttpHandler =
806
+
fun next ctx ->
807
+
let html =
808
+
"""<html>
809
+
<head><title>PDSharp</title></head>
810
+
<body>
811
+
<pre>
812
+
888 888 8888888888 888 888
813
+
888 888 888 888 888
814
+
888 888 888 888888888888
815
+
8888b. 888888 88888b. 888d888 .d88b. 888888 .d88b. 88 8888888 888 888
816
+
"88b 888 888 "88b 888P" d88""88b 888 d88""88b 888888 888 888 888
817
+
.d888888 888 888 888 888 888 888 888 888 888 88 888 888888888888
818
+
888 888 Y88b. 888 d88P 888 Y88..88P Y88b. Y88..88P 888 888 888
819
+
"Y888888 "Y888 88888P" 888 "Y88P" "Y888 "Y88P" 888 888 888
820
+
888
821
+
888
822
+
888
823
+
824
+
825
+
This is an AT Protocol Personal Data Server (aka, an atproto PDS)
826
+
827
+
Most API routes are under /xrpc/
828
+
829
+
Code: https://github.com/bluesky-social/atproto
830
+
https://github.com/stormlightlabs/PDSharp
831
+
https://tangled.org/desertthunder.dev/PDSharp
832
+
Self-Host: https://github.com/bluesky-social/pds
833
+
Protocol: https://atproto.com
834
+
</pre>
835
+
</body>
836
+
</html>"""
837
+
838
+
ctx.SetContentType "text/html"
839
+
ctx.SetStatusCode 200
840
+
ctx.WriteStringAsync html
841
+
796
842
let webApp =
797
843
choose [
798
844
GET
799
-
>=> route "/xrpc/com.atproto.server.describeServer"
800
-
>=> describeServerHandler
845
+
>=> choose [
846
+
route "/" >=> indexHandler
847
+
route "/xrpc/com.atproto.server.describeServer" >=> describeServerHandler
848
+
]
801
849
POST >=> route "/xrpc/com.atproto.server.createAccount" >=> createAccountHandler
802
850
POST >=> route "/xrpc/com.atproto.server.createSession" >=> createSessionHandler
803
851
POST
+4
-4
roadmap.txt
+4
-4
roadmap.txt
···
55
55
--------------------------------------------------------------------------------
56
56
Milestone I: Lexicon Validation + Conformance
57
57
--------------------------------------------------------------------------------
58
-
- Lexicon validation for writes (app.bsky.* records)
59
-
- Conformance testing: diff CIDs/CARs/signatures vs reference PDS
58
+
- [x] Lexicon validation for writes (app.bsky.* records)
59
+
- [x] Conformance testing: diff CIDs/CARs/signatures vs reference PDS
60
60
DoD: Same inputs → same outputs for repo/sync surfaces
61
61
--------------------------------------------------------------------------------
62
-
Milestone J: Persistence + Backups (Self-hosted PDS)
62
+
Milestone J: Persistence + Backups
63
63
--------------------------------------------------------------------------------
64
64
Deliverables:
65
65
- BackupOps module in Core (scheduler unit / cron / scripts, plus Litestream config)
···
114
114
- Upload blob, verify retrieval via sync.getBlob
115
115
DoD: Posts appear in clients, media loads reliably
116
116
--------------------------------------------------------------------------------
117
-
Milestone O: Account Migration (Optional)
117
+
Milestone O: Account Migration
118
118
--------------------------------------------------------------------------------
119
119
- Export/import from bsky.social
120
120
- Update DID service endpoint