@@ -0,0 +1,234 @@
1+module Roundtrip.Spec where
2+
3+import Prelude
4+
5+import Data.Maybe (Maybe(..))
6+import Effect.Aff (bracket)
7+import Effect.Aff.Class (liftAff)
8+import Effect.Class (liftEffect)
9+import Test.Spec (Spec, around, describe, it)
10+import Test.Spec.Assertions (shouldEqual)
11+import Yoga.Fastify.Fastify as F
12+import Yoga.Fastify.Fastify (Port(..), Host(..))
13+import Yoga.Fastify.Om.API (registerAPI)
14+import Yoga.Fastify.Om.Route (Handler, handle, respond, reject, BearerToken(..))
15+import Yoga.Fetch.Om (GET, POST, PUT, DELETE, Route, JSON, type (/), type (:), type (:?), client)
16+import Yoga.Om (Om, ask, handleErrors, runOm)
17+
18+-- Types
19+
20+type User = { id :: Int, name :: String, email :: String }
21+type CreateUserReq = { name :: String, email :: String }
22+type ErrorMsg = { error :: String }
23+
24+-- Route definitions shared by server and client
25+
26+type GetUserRoute = Route GET
27+ ("users" / "id" : Int)
28+ {}
29+ ( ok :: { body :: User }
30+ , notFound :: { body :: ErrorMsg }
31+ )
32+
33+type ListUsersRoute = Route GET
34+ ("users" :? { limit :: Int, offset :: Int })
35+ {}
36+ (ok :: { body :: Array User })
37+
38+type CreateUserRoute = Route POST
39+ "users"
40+ { body :: JSON CreateUserReq }
41+ ( created :: { body :: User }
42+ , badRequest :: { body :: ErrorMsg }
43+ )
44+
45+type UpdateUserRoute = Route PUT
46+ ("users" / "id" : Int)
47+ { body :: JSON CreateUserReq }
48+ ( ok :: { body :: User }
49+ , notFound :: { body :: ErrorMsg }
50+ )
51+
52+type DeleteUserRoute = Route DELETE
53+ ("users" / "id" : Int)
54+ {}
55+ ( ok :: { body :: {} }
56+ , notFound :: { body :: ErrorMsg }
57+ )
58+
59+type AuthRoute = Route GET
60+ "me"
61+ { headers :: { authorization :: BearerToken } }
62+ ( ok :: { body :: User }
63+ , unauthorized :: { body :: ErrorMsg }
64+ )
65+
66+type API =
67+ { getUser :: GetUserRoute
68+ , listUsers :: ListUsersRoute
69+ , createUser :: CreateUserRoute
70+ , updateUser :: UpdateUserRoute
71+ , deleteUser :: DeleteUserRoute
72+ , me :: AuthRoute
73+ }
74+
75+api = client @API "http://localhost:44932"
76+
77+-- Handlers
78+
79+getUserHandler :: Handler GetUserRoute ()
80+getUserHandler = handle do
81+ { path } <- ask
82+ if path.id == 42
83+ then respond @"ok" { id: 42, name: "Alice", email: "alice@test.com" }
84+ else reject @"notFound" { error: "User " <> show path.id <> " not found" }
85+
86+listUsersHandler :: Handler ListUsersRoute ()
87+listUsersHandler = handle do
88+ { query } <- ask
89+ let users = [ { id: 1, name: "Alice", email: "a@t.com" }
90+ , { id: 2, name: "Bob", email: "b@t.com" }
91+ , { id: 3, name: "Charlie", email: "c@t.com" }
92+ ]
93+ let limited = case query.limit of
94+ Just l -> take l users
95+ Nothing -> users
96+ respond @"ok" limited
97+ where
98+ take n xs = if n <= 0 then [] else case xs of
99+ [] -> []
100+ [a] -> [a]
101+ [a, _] | n == 1 -> [a]
102+ [a, b] -> [a, b]
103+ _ -> xs
104+
105+createUserHandler :: Handler CreateUserRoute ()
106+createUserHandler = handle do
107+ { body } <- ask
108+ if body.name == ""
109+ then reject @"badRequest" { error: "Name required" }
110+ else respond @"created" { id: 99, name: body.name, email: body.email }
111+
112+updateUserHandler :: Handler UpdateUserRoute ()
113+updateUserHandler = handle do
114+ { path, body } <- ask
115+ if path.id /= 42
116+ then reject @"notFound" { error: "Not found" }
117+ else respond @"ok" { id: path.id, name: body.name, email: body.email }
118+
119+deleteUserHandler :: Handler DeleteUserRoute ()
120+deleteUserHandler = handle do
121+ { path } <- ask
122+ if path.id /= 42
123+ then reject @"notFound" { error: "Not found" }
124+ else respond @"ok" {}
125+
126+meHandler :: Handler AuthRoute ()
127+meHandler = handle do
128+ { headers } <- ask
129+ case headers.authorization of
130+ BearerToken "secret" -> respond @"ok" { id: 1, name: "Admin", email: "admin@test.com" }
131+ _ -> reject @"unauthorized" { error: "Invalid token" }
132+
133+-- Test suite
134+
135+spec :: Spec Unit
136+spec = around withServer $ describe "server ↔ client roundtrip" do
137+
138+ describe "GET with path params" do
139+ it "returns user for valid id" \_ ->
140+ runOm {} { exception: \_ -> pure unit } do
141+ user <- api.getUser { id: 42 }
142+ # handleErrors { notFound: \e -> pure { id: 0, name: e.error, email: "" } }
143+ liftAff $ user.name `shouldEqual` "Alice"
144+
145+ it "returns notFound for invalid id" \_ ->
146+ runOm {} { exception: \_ -> pure unit } do
147+ user <- api.getUser { id: 999 }
148+ # handleErrors { notFound: \e -> pure { id: 0, name: e.error, email: "" } }
149+ liftAff $ user.name `shouldEqual` "User 999 not found"
150+
151+ describe "GET with query params" do
152+ it "passes query params correctly" \_ ->
153+ runOm {} { exception: \_ -> pure unit } do
154+ users <- api.listUsers { limit: Just 1, offset: Nothing }
155+ liftAff $ (map _.name users) `shouldEqual` ["Alice"]
156+
157+ it "handles no query params" \_ ->
158+ runOm {} { exception: \_ -> pure unit } do
159+ users <- api.listUsers { limit: Nothing, offset: Nothing }
160+ liftAff $ (map _.name users) `shouldEqual` ["Alice", "Bob", "Charlie"]
161+
162+ describe "POST with JSON body" do
163+ it "sends and receives JSON body" \_ ->
164+ runOm {} { exception: \_ -> pure unit } do
165+ user <- api.createUser { name: "Dave", email: "d@t.com" }
166+ # handleErrors { badRequest: \e -> pure { id: 0, name: e.error, email: "" } }
167+ liftAff do
168+ user.name `shouldEqual` "Dave"
169+ user.email `shouldEqual` "d@t.com"
170+ user.id `shouldEqual` 99
171+
172+ it "rejects with badRequest for empty name" \_ ->
173+ runOm {} { exception: \_ -> pure unit } do
174+ user <- api.createUser { name: "", email: "e@t.com" }
175+ # handleErrors { badRequest: \e -> pure { id: 0, name: e.error, email: "" } }
176+ liftAff $ user.name `shouldEqual` "Name required"
177+
178+ describe "PUT with path params and JSON body" do
179+ it "sends path params and body together" \_ ->
180+ runOm {} { exception: \_ -> pure unit } do
181+ user <- api.updateUser { id: 42 } { name: "Updated", email: "u@t.com" }
182+ # handleErrors { notFound: \e -> pure { id: 0, name: e.error, email: "" } }
183+ liftAff do
184+ user.id `shouldEqual` 42
185+ user.name `shouldEqual` "Updated"
186+
187+ describe "DELETE with path params" do
188+ it "deletes successfully" \_ ->
189+ runOm {} { exception: \_ -> pure unit } do
190+ result <- api.deleteUser { id: 42 }
191+ # handleErrors { notFound: \_ -> pure {} }
192+ liftAff $ result `shouldEqual` {}
193+
194+ it "returns notFound for wrong id" \_ ->
195+ runOm {} { exception: \_ -> pure unit } do
196+ result <- api.deleteUser { id: 1 }
197+ # handleErrors { notFound: \_ -> pure {} }
198+ liftAff $ result `shouldEqual` {}
199+
200+ describe "GET with authorization header" do
201+ it "passes bearer token in header" \_ ->
202+ runOm {} { exception: \_ -> pure unit } do
203+ user <- api.me { authorization: BearerToken "secret" }
204+ # handleErrors { unauthorized: \e -> pure { id: 0, name: e.error, email: "" } }
205+ liftAff $ user.name `shouldEqual` "Admin"
206+
207+ it "rejects unauthorized" \_ ->
208+ runOm {} { exception: \_ -> pure unit } do
209+ user <- api.me { authorization: BearerToken "wrong" }
210+ # handleErrors { unauthorized: \e -> pure { id: 0, name: e.error, email: "" } }
211+ liftAff $ user.name `shouldEqual` "Invalid token"
212+
213+-- Server setup
214+
215+withServer :: forall a. (Unit -> _ a) -> _ a
216+withServer test = bracket acquire release (\_ -> test unit)
217+ where
218+ acquire = do
219+ fastify <- liftEffect do
220+ f <- F.fastify {}
221+ registerAPI
222+ { getUser: getUserHandler
223+ , listUsers: listUsersHandler
224+ , createUser: createUserHandler
225+ , updateUser: updateUserHandler
226+ , deleteUser: deleteUserHandler
227+ , me: meHandler
228+ }
229+ f
230+ pure f
231+ void $ F.listen { port: Port 44932, host: Host "0.0.0.0" } fastify
232+ pure fastify
233+
234+ release = F.close