├── .gitignore ├── .purs-repl ├── API-SPEC.md ├── APPROACH.md ├── LICENSE ├── README.md ├── config └── Server │ ├── Dev.json │ └── Prod.json ├── package-lock.json ├── package.json ├── packages.dhall ├── spago.dhall ├── sql ├── CreateDB.sql ├── Functions.sql ├── ResetTables.sql └── Sandbox.sql ├── src ├── Main.purs ├── Server │ ├── Article │ │ ├── Api │ │ │ ├── Interface │ │ │ │ └── Spec.purs │ │ │ ├── Main.purs │ │ │ └── Type │ │ │ │ ├── CreateDto.purs │ │ │ │ ├── Misc.purs │ │ │ │ └── UpdateDto.purs │ │ ├── Interface │ │ │ └── Persistence.purs │ │ ├── Persistence │ │ │ └── Postgres │ │ │ │ ├── Main.purs │ │ │ │ ├── Type │ │ │ │ └── Misc.purs │ │ │ │ └── Validation.purs │ │ └── Type │ │ │ └── Misc.purs │ ├── Comment │ │ ├── Api │ │ │ ├── Interface │ │ │ │ └── Spec.purs │ │ │ ├── Main.purs │ │ │ └── Type │ │ │ │ ├── CreateDto.purs │ │ │ │ └── Misc.purs │ │ ├── Interface │ │ │ └── Persistence.purs │ │ ├── Persistence │ │ │ └── Postgres │ │ │ │ ├── Main.purs │ │ │ │ ├── Type │ │ │ │ └── Misc.purs │ │ │ │ └── Validation.purs │ │ └── Type │ │ │ └── Misc.purs │ ├── Main.purs │ ├── Profile │ │ ├── Api │ │ │ ├── Interface │ │ │ │ └── Spec.purs │ │ │ ├── Main.purs │ │ │ └── Type │ │ │ │ └── Misc.purs │ │ ├── Interface │ │ │ └── Persistence.purs │ │ ├── Persistence │ │ │ └── Postgres │ │ │ │ ├── Main.purs │ │ │ │ ├── Type │ │ │ │ └── Misc.purs │ │ │ │ └── Validation.purs │ │ └── Type │ │ │ └── Misc.purs │ ├── Shared │ │ ├── Api │ │ │ ├── Headers.purs │ │ │ ├── Interface │ │ │ │ └── Spec.purs │ │ │ ├── Main.purs │ │ │ └── Type │ │ │ │ └── Misc.purs │ │ ├── Interface │ │ │ ├── Aggregate.purs │ │ │ ├── Persistence.purs │ │ │ └── Token.purs │ │ ├── Persistence │ │ │ ├── Main.purs │ │ │ └── Postgres │ │ │ │ └── Type │ │ │ │ └── Misc.purs │ │ ├── Type │ │ │ └── Misc.purs │ │ └── Util │ │ │ ├── Json.purs │ │ │ └── Selda.purs │ ├── Shell │ │ ├── Api │ │ │ ├── Guards.purs │ │ │ ├── Interface │ │ │ │ └── Spec.purs │ │ │ └── Main.purs │ │ ├── Main.purs │ │ ├── Persistence │ │ │ └── Postgres │ │ │ │ └── Main.purs │ │ ├── Type │ │ │ ├── DebugLevel.purs │ │ │ ├── Misc.purs │ │ │ └── PersistenceImpl.purs │ │ └── Util │ │ │ ├── Aggregate.purs │ │ │ ├── Config.purs │ │ │ └── Token.purs │ └── User │ │ ├── Api │ │ ├── Interface │ │ │ └── Spec.purs │ │ ├── Main.purs │ │ └── Type │ │ │ ├── CreateDto.purs │ │ │ ├── LoginDto.purs │ │ │ ├── Misc.purs │ │ │ └── UpdateDto.purs │ │ ├── Interface │ │ └── Persistence.purs │ │ ├── Persistence │ │ └── Postgres │ │ │ ├── Main.purs │ │ │ ├── Type │ │ │ └── Misc.purs │ │ │ └── Validation.purs │ │ └── Type │ │ ├── Misc.purs │ │ └── Test.purs └── Shared │ ├── Type │ ├── LongString.purs │ ├── LowercaseString.purs │ ├── Misc.purs │ └── ShortString.purs │ └── Util │ ├── Maybe.purs │ └── String.purs └── test ├── Main.purs ├── ResetTables.purs └── Server ├── Article ├── CreateJimSuccessRequest.json ├── CreateSuccessRequest.json ├── Multiple0Response.json ├── Multiple2Response.json ├── MultipleJakeResponse.json ├── MultipleJimFavoritedResponse.json ├── MultipleJimFollowingResponse.json ├── MultipleJimResponse.json ├── SingleJimResponse.json ├── SingleResponse.json ├── TagsResponse.json ├── UpdateBackSuccessRequest.json ├── UpdateSuccessRequest.json └── UpdateSuccessResponse.json ├── Comment ├── CreateSuccessRequest.json ├── MultipleResponse.json └── SingleResponse.json ├── Profile ├── FollowFail422Response.json ├── FollowSuccessResponse.json ├── GetSuccessResponse.json ├── RequestFail404Response.json └── UnfollowSuccessResponse.json ├── Shell ├── Interface │ └── Api.purs ├── Main.purs ├── Persistence │ └── Postgres.purs ├── TestCases.json ├── Type │ └── Misc.purs └── Util │ └── Payload.purs └── User ├── LoginFail400EmptyFieldRequest.json ├── LoginFail400EmptyFieldResponse.json ├── LoginFail400MissingFieldRequest.json ├── LoginFail400MissingFieldResponse.json ├── LoginFail404Request.json ├── LoginFail404Response.json ├── LoginJimSuccessRequest.json ├── LoginSuccessRequest.json ├── RegisterJimSuccessRequest.json ├── RegisterSuccessRequest.json ├── RequestJimSuccessResponse.json ├── RequestSuccessResponse.json ├── UpdateBackSuccessRequest.json ├── UpdateSuccessRequest.json └── UpdateSuccessResponse.json /.gitignore: -------------------------------------------------------------------------------- 1 | # Dependencies 2 | .psci_modules 3 | bower_components 4 | node_modules 5 | 6 | # Generated files 7 | .psci 8 | output 9 | /.pulp-cache/ 10 | /output/ 11 | /generated-docs/ 12 | /.psc-package/ 13 | /.psc* 14 | /.purs* 15 | /.psa* 16 | /.spago 17 | /.psc-ide-port -------------------------------------------------------------------------------- /.purs-repl: -------------------------------------------------------------------------------- 1 | import Prelude 2 | -------------------------------------------------------------------------------- /API-SPEC.md: -------------------------------------------------------------------------------- 1 | # RealWorld API Spec 2 | 3 | ## Running API tests locally 4 | 5 | To locally run the provided Postman collection against your backend, execute: 6 | 7 | ```text 8 | APIURL=http://localhost:3000/api ./run-api-tests.sh 9 | ``` 10 | 11 | For more details, see [`run-api-tests.sh`](run-api-tests.sh). 12 | 13 | ## Considerations for your backend with [CORS](https://en.wikipedia.org/wiki/Cross-origin_resource_sharing) 14 | 15 | If the backend is about to run on a different host/port than the frontend, make sure to handle `OPTIONS` too and return correct `Access-Control-Allow-Origin` and `Access-Control-Allow-Headers` (e.g. `Content-Type`). 16 | 17 | ### Authentication Header 18 | 19 | `Authorization: Token jwt.token.here` 20 | 21 | ## JSON Objects returned by API 22 | 23 | Make sure the right content type like `Content-Type: application/json; charset=utf-8` is correctly returned. 24 | 25 | ### Users (for authentication) 26 | 27 | ```JSON 28 | { 29 | "user": { 30 | "email": "jake@jake.jake", 31 | "token": "jwt.token.here", 32 | "username": "jake", 33 | "bio": "I work at statefarm", 34 | "image": null 35 | } 36 | } 37 | ``` 38 | 39 | ### Profile 40 | 41 | ```JSON 42 | { 43 | "profile": { 44 | "username": "jake", 45 | "bio": "I work at statefarm", 46 | "image": "https://static.productionready.io/images/smiley-cyrus.jpg", 47 | "following": false 48 | } 49 | } 50 | ``` 51 | 52 | ### Single Article 53 | 54 | ```JSON 55 | { 56 | "article": { 57 | "slug": "how-to-train-your-dragon", 58 | "title": "How to train your dragon", 59 | "description": "Ever wonder how?", 60 | "body": "It takes a Jacobian", 61 | "tagList": ["dragons", "training"], 62 | "createdAt": "2016-02-18T03:22:56.637Z", 63 | "updatedAt": "2016-02-18T03:48:35.824Z", 64 | "favorited": false, 65 | "favoritesCount": 0, 66 | "author": { 67 | "username": "jake", 68 | "bio": "I work at statefarm", 69 | "image": "https://i.stack.imgur.com/xHWG8.jpg", 70 | "following": false 71 | } 72 | } 73 | } 74 | ``` 75 | 76 | ### Multiple Articles 77 | 78 | ```JSON 79 | { 80 | "articles":[{ 81 | "slug": "how-to-train-your-dragon", 82 | "title": "How to train your dragon", 83 | "description": "Ever wonder how?", 84 | "body": "It takes a Jacobian", 85 | "tagList": ["dragons", "training"], 86 | "createdAt": "2016-02-18T03:22:56.637Z", 87 | "updatedAt": "2016-02-18T03:48:35.824Z", 88 | "favorited": false, 89 | "favoritesCount": 0, 90 | "author": { 91 | "username": "jake", 92 | "bio": "I work at statefarm", 93 | "image": "https://i.stack.imgur.com/xHWG8.jpg", 94 | "following": false 95 | } 96 | }, { 97 | "slug": "how-to-train-your-dragon-2", 98 | "title": "How to train your dragon 2", 99 | "description": "So toothless", 100 | "body": "It a dragon", 101 | "tagList": ["dragons", "training"], 102 | "createdAt": "2016-02-18T03:22:56.637Z", 103 | "updatedAt": "2016-02-18T03:48:35.824Z", 104 | "favorited": false, 105 | "favoritesCount": 0, 106 | "author": { 107 | "username": "jake", 108 | "bio": "I work at statefarm", 109 | "image": "https://i.stack.imgur.com/xHWG8.jpg", 110 | "following": false 111 | } 112 | }], 113 | "articlesCount": 2 114 | } 115 | ``` 116 | 117 | ### Single Comment 118 | 119 | ```JSON 120 | { 121 | "comment": { 122 | "id": 1, 123 | "createdAt": "2016-02-18T03:22:56.637Z", 124 | "updatedAt": "2016-02-18T03:22:56.637Z", 125 | "body": "It takes a Jacobian", 126 | "author": { 127 | "username": "jake", 128 | "bio": "I work at statefarm", 129 | "image": "https://i.stack.imgur.com/xHWG8.jpg", 130 | "following": false 131 | } 132 | } 133 | } 134 | ``` 135 | 136 | ### Multiple Comments 137 | 138 | ```JSON 139 | { 140 | "comments": [{ 141 | "id": 1, 142 | "createdAt": "2016-02-18T03:22:56.637Z", 143 | "updatedAt": "2016-02-18T03:22:56.637Z", 144 | "body": "It takes a Jacobian", 145 | "author": { 146 | "username": "jake", 147 | "bio": "I work at statefarm", 148 | "image": "https://i.stack.imgur.com/xHWG8.jpg", 149 | "following": false 150 | } 151 | }] 152 | } 153 | ``` 154 | 155 | ### List of Tags 156 | 157 | ```JSON 158 | { 159 | "tags": [ 160 | "reactjs", 161 | "angularjs" 162 | ] 163 | } 164 | ``` 165 | 166 | ### Errors and Status Codes 167 | 168 | If a request fails any validations, expect a 422 and errors in the following format: 169 | 170 | ```JSON 171 | { 172 | "errors":{ 173 | "body": [ 174 | "can't be empty" 175 | ] 176 | } 177 | } 178 | ``` 179 | 180 | #### Other status codes 181 | 182 | 401 for Unauthorized requests, when a request requires authentication but it isn't provided 183 | 184 | 403 for Forbidden requests, when a request may be valid but the user doesn't have permissions to perform the action 185 | 186 | 404 for Not found requests, when a resource can't be found to fulfill the request 187 | 188 | ## Endpoints 189 | 190 | ### Authentication 191 | 192 | 1. Spec.: 193 | 194 | `POST /api/users/login` 195 | 196 | Example request body: 197 | 198 | ```JSON 199 | { 200 | "user":{ 201 | "email": "jake@jake.jake", 202 | "password": "jakejake" 203 | } 204 | } 205 | ``` 206 | 207 | No authentication required, returns a [User](#users-for-authentication) 208 | 209 | Required fields: `email`, `password` 210 | 211 | 1. Tests calls: 212 | 213 | ```sh 214 | http POST http://localhost:3000/api/users/login < test/Server/User/LoginSuccessRequest.json Origin:"http://example.com" 215 | http POST http://localhost:3000/api/users/login < test/Server/User/LoginFail... Origin:"http://example.com" 216 | ``` 217 | 218 | ### Registration 219 | 220 | 1. Spec.: 221 | 222 | `POST /api/users` 223 | 224 | Example request body: 225 | 226 | ```JSON 227 | { 228 | "user":{ 229 | "username": "Jacob", 230 | "email": "jake@jake.jake", 231 | "password": "jakejake" 232 | } 233 | } 234 | ``` 235 | 236 | No authentication required, returns a [User](#users-for-authentication) 237 | 238 | Required fields: `email`, `username`, `password` 239 | 240 | 1. Tests calls: 241 | 242 | ```sh 243 | http POST http://localhost:3000/api/users < test/Server/User/RegisterSuccessRequest.json Origin:"http://example.com" 244 | ``` 245 | 246 | ### Get Current User 247 | 248 | 1. Spec.: 249 | 250 | `GET /api/user` 251 | 252 | Authentication required, returns a [User](#users-for-authentication) that's the current user 253 | 254 | 1. Tests calls: 255 | 256 | ```sh 257 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" GET http://localhost:3000/api/user Origin:"http://example.com" 258 | 259 | http --auth-type=jwt --auth="INVALID TOKEN" GET http://localhost:3000/api/user Origin:"http://example.com" 260 | ``` 261 | 262 | ### Update User 263 | 264 | 1. Spec.: 265 | 266 | `PUT /api/user` 267 | 268 | Example request body: 269 | 270 | ```JSON 271 | { 272 | "user":{ 273 | "email": "jake@jake.jake", 274 | "bio": "I like to skateboard", 275 | "image": "https://i.stack.imgur.com/xHWG8.jpg" 276 | } 277 | } 278 | ``` 279 | 280 | Authentication required, returns the [User](#users-for-authentication) 281 | 282 | Accepted fields: `email`, `username`, `password`, `image`, `bio` 283 | 284 | 1. Tests calls: 285 | 286 | ```sh 287 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" PUT http://localhost:3000/api/user < test/Server/User/UpdateSuccessRequest.json Origin:"http://example.com" 288 | ``` 289 | 290 | ### Get Profile 291 | 292 | 1. Spec.: 293 | 294 | `GET /api/profiles/:username` 295 | 296 | Authentication optional, returns a [Profile](#profile) 297 | 298 | 1. Test calls: 299 | 300 | ```sh 301 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjJ9.qljK8m23kwkwi9meZhbt11CeYCvdd9F55_1RJWZ-ggs" GET http://localhost:3000/api/profiles/jim Origin:"http://example.com" 302 | ``` 303 | 304 | ### Follow user 305 | 306 | 1. Spec.: 307 | 308 | `POST /api/profiles/:username/follow` 309 | 310 | Authentication required, returns a [Profile](#profile) 311 | 312 | No additional parameters required 313 | 314 | 1. Test calls: 315 | 316 | ```sh 317 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" POST http://localhost:3000/api/profiles/jim/follow Origin:"http://example.com" 318 | ``` 319 | 320 | ### Unfollow user 321 | 322 | 1. Spec.: 323 | 324 | `DELETE /api/profiles/:username/follow` 325 | 326 | Authentication required, returns a [Profile](#profile) 327 | 328 | No additional parameters required 329 | 330 | 1. Test calls: 331 | 332 | ```sh 333 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" DELETE http://localhost:3000/api/profiles/jim/follow Origin:"http://example.com" 334 | ``` 335 | 336 | ### List Articles 337 | 338 | 1. Spec.: 339 | 340 | `GET /api/articles` 341 | 342 | Returns most recent articles globally by default, provide `tag`, `author` or `favorited` query parameter to filter results 343 | 344 | Query Parameters: 345 | 346 | Filter by tag: 347 | 348 | `?tag=AngularJS` 349 | 350 | Filter by author: 351 | 352 | `?author=jake` 353 | 354 | Favorited by user: 355 | 356 | `?favorited=jake` 357 | 358 | Limit number of articles (default is 20): 359 | 360 | `?limit=20` 361 | 362 | Offset/skip number of articles (default is 0): 363 | 364 | `?offset=0` 365 | 366 | Authentication optional, will return [multiple articles](#multiple-articles), ordered by most recent first 367 | 368 | 1. Test calls: 369 | 370 | ```sh 371 | http GET "http://localhost:3000/api/articles?tag=AngularJS&author=jake&favorited=jake&limit=1&offset=1" Origin:"http://example.com" 372 | http GET "http://localhost:3000/api/articles?author=Jake" Origin:"http://example.com" 373 | ``` 374 | 375 | ### Feed Articles 376 | 377 | 1. Spec.: 378 | 379 | `GET /api/articles/feed` 380 | 381 | Can also take `limit` and `offset` query parameters like [List Articles](#list-articles) 382 | 383 | Authentication required, will return [multiple articles](#multiple-articles) created by followed users, ordered by most recent first. 384 | 385 | 1. Test calls: 386 | 387 | ```sh 388 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" GET "http://localhost:3000/api/articles/feed?limit=100&offset=0" Origin:"http://example.com" 389 | ``` 390 | 391 | 1. Minor Problem: The log displays two matches: 392 | 393 | ```log 394 | GET api/articles/feed -> 2 matches: 395 | GET /api/articles/feed 396 | GET /api/articles/ 397 | ``` 398 | 399 | ### Get Article 400 | 401 | 1. Spec.: 402 | 403 | `GET /api/articles/:slug` 404 | 405 | No authentication required, will return [single article](#single-article) 406 | 407 | 1. Test calls: 408 | 409 | ```sh 410 | http GET "http://localhost:3000/api/articles/how-to-train-your-dragon" Origin:"http://example.com" 411 | ``` 412 | 413 | ### Create Article 414 | 415 | 1. Spec.: 416 | 417 | `POST /api/articles` 418 | 419 | Example request body: 420 | 421 | ```JSON 422 | { 423 | "article": { 424 | "title": "How to train your dragon", 425 | "description": "Ever wonder how?", 426 | "body": "You have to believe", 427 | "tagList": ["reactjs", "angularjs", "dragons"] 428 | } 429 | } 430 | ``` 431 | 432 | Authentication required, will return an [Article](#single-article) 433 | 434 | Required fields: `title`, `description`, `body` 435 | 436 | Optional fields: `tagList` as an array of Strings 437 | 438 | 1. Test calls 439 | 440 | ```sh 441 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" POST "http://localhost:3000/api/articles" < test/Server/Article/CreateSuccessRequest.json Origin:"http://example.com" 442 | ``` 443 | 444 | ### Update Article 445 | 446 | 1. Spec.: 447 | 448 | `PUT /api/articles/:slug` 449 | 450 | Example request body: 451 | 452 | ```JSON 453 | { 454 | "article": { 455 | "title": "Did you train your dragon?" 456 | } 457 | } 458 | ``` 459 | 460 | Authentication required, returns the updated [Article](#single-article) 461 | 462 | Optional fields: `title`, `description`, `body` 463 | 464 | The `slug` also gets updated when the `title` is changed 465 | 466 | 1. Test calls 467 | 468 | ```sh 469 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" PUT "http://localhost:3000/api/articles/how-to-train-your-dragon" < test/Server/Article/UpdateSuccessRequest.json Origin:"http://example.com" 470 | ``` 471 | 472 | ### Delete Article 473 | 474 | 1. Spec.: 475 | 476 | `DELETE /api/articles/:slug` 477 | 478 | Authentication required 479 | 480 | 1. Test calls: 481 | 482 | ```sh 483 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" DELETE "http://localhost:3000/api/articles/how-to-train-your-dragon" Origin:"http://example.com" 484 | ``` 485 | 486 | ### Add Comments to an Article 487 | 488 | 1. Spec.: 489 | 490 | `POST /api/articles/:slug/comments` 491 | 492 | Example request body: 493 | 494 | ```JSON 495 | { 496 | "comment": { 497 | "body": "His name was my name too." 498 | } 499 | } 500 | ``` 501 | 502 | Authentication required, returns the created [Comment](#single-comment) 503 | 504 | Required field: `body` 505 | 506 | 1. Tests calls: 507 | 508 | ```sh 509 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" POST http://localhost:3000/api/articles/how-to-train-your-dragon/comments < test/Server/Comment/CreateSuccessRequest.json Origin:"http://example.com" 510 | ``` 511 | 512 | ### Get Comments from an Article 513 | 514 | 1. Spec.: 515 | 516 | `GET /api/articles/:slug/comments` 517 | 518 | Authentication optional, returns [multiple comments](#multiple-comments) 519 | 520 | 1. Tests calls: 521 | 522 | ```sh 523 | http GET http://localhost:3000/api/articles/how-to-train-your-dragon/comments 524 | ``` 525 | 526 | ### Delete Comment 527 | 528 | 1. Spec.: 529 | 530 | `DELETE /api/articles/:slug/comments/:id` 531 | 532 | Authentication required 533 | 534 | 1. Tests calls: 535 | 536 | ```sh 537 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" DELETE http://localhost:3000/api/articles/how-to-train-your-dragon/comments/3 Origin:"http://example.com" 538 | ``` 539 | 540 | ### Favorite Article 541 | 542 | 1. Spec.: 543 | 544 | `POST /api/articles/:slug/favorite` 545 | 546 | Authentication required, returns the [Article](#single-article) 547 | 548 | No additional parameters required 549 | 550 | 1. Test calls: 551 | 552 | ```sh 553 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" POST "http://localhost:3000/api/articles/how-to-train-your-dragon/favorite" Origin:"http://example.com" 554 | ``` 555 | 556 | ### Unfavorite Article 557 | 558 | 1. Spec.: 559 | 560 | `DELETE /api/articles/:slug/favorite` 561 | 562 | Authentication required, returns the [Article](#single-article) 563 | 564 | No additional parameters required 565 | 566 | 1. Test calls: 567 | 568 | ```sh 569 | http --auth-type=jwt --auth="eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" DELETE "http://localhost:3000/api/articles/how-to-train-your-dragon/favorite" Origin:"http://example.com" 570 | ``` 571 | 572 | ### Get Tags 573 | 574 | 1. Spec.: 575 | 576 | `GET /api/tags` 577 | 578 | No authentication required, returns a [List of Tags](#list-of-tags) 579 | 580 | 1. Test calls: 581 | 582 | ```sh 583 | http GET http://localhost:3000/api/tags Origin:"http://example.com" 584 | ``` 585 | -------------------------------------------------------------------------------- /APPROACH.md: -------------------------------------------------------------------------------- 1 | # Approach 2 | 3 | This file contains some comments about the decisions which were made. 4 | 5 | ## Source code file and folder structure 6 | 7 | 1. The goals are: 8 | 1. Minimal source code repetition which includes a minimal amount of boilerplate code. 9 | 1. Short names. 10 | 1. Short files. 11 | 1. Expectable behavior. 12 | 1. Minimal costs of changes, especially of infrastructure changes. 13 | 1. Easily testable via command line tools and automated tests. 14 | 15 | 1. The general source code file and folder structure is `////`. 16 | 1. ``: 17 | 1. `config`: For config files. 18 | 1. `sql`: Contains sql scripts for development and database setup. 19 | 1. `src`: PureScript and JavaScript development source files. 20 | 1. `test`: PureScript and Json source files for testing. Test can depend on `src` but not vice versa. 21 | 1. ``: 22 | 1. `Client`: Code which is only used in the client application. (Not implemented) 23 | 1. `Server`: Code which is only used in the server application. `Server` can only depend on `Shared`. The entry point for the server application is called `Main.purs` 24 | 1. `Shared`: Code which is of general usage. 25 | 1. ``: 26 | 1. `Shell`: For the entry point of the application and to direct to other domains. `Shell` can depend on other domains. Other domains cannot depend on `Shell` 27 | 1. `User` etc.: Domain code. The domain should be independent. Function names should be equal across domains with different signature depending on the context. 28 | 1. `Shared`: Code which can be used by all domains. Other domains can depend on `Shared`. `Shared` cannot depend on other domains. 29 | 1. ``: 30 | 1. `Api`: Entry points of requests and validation logic. This layer can depend on `Application`. 31 | 1. `Application`: Business application layer. Effects can only be used with interfaces. If the business logic is just one call to another layer, the call is made directly and the declaration in `Application` is omitted. 32 | 1. `Interface`: Interfaces for persistence or application functions. 33 | 1. `Persistence`: Persistence/storage/database layer. 34 | 1. `Util`: Holds util functions. They can be accessed via interfaces. 35 | 1. `Type`: Holds types which can be used by all layers of the domain. If a type is only used by one layer, it is placed directly under this layer. 36 | 1. ``: 37 | 1. If there can be multiple implementations of the same layer, a distinct name is used. 38 | 1. `Main.purs` refers to the general implementation/entrance point of a folder. 39 | 1. The ideal file length is two pages. Simple types are usually shorter, that's why they are placed under `Misc.purs`. 40 | 1. The handle pattern was used for dependency injection [(Van der Jeugt, 2018)](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html). 41 | 1. The structure for holding the dependencies is called `Handle`. 42 | 1. The function for getting an implementations is called `mkHandle`. 43 | 1. The namespace for aggregating two or more handles is called `Aggregate`. 44 | 1. The source code is written for qualified import, which is also mentioned at [(Van der Jeugt, 2018)](https://jaspervdj.be/posts/2018-03-08-handle-pattern.html). 45 | 1. Actual Qualifiers like `import ... as Payload` should be used sparingly because they can't be created automatically by the *PureScript VS Code IDE*. Also the names are arbitrary. 46 | 1. The expression order in a code line should be from right to left. 47 | 1. If the order of parameters, arrays, records, etc. is arbitrary, it should be ordered alphabetically in the source code. 48 | 49 | ## Comments 50 | 51 | 1. PostgreSQL: 52 | 1. In order to create type-safe sql queries [purescript-selda](https://github.com/Kamirus/purescript-selda) was used. 53 | 1. As of the time of writing, there was a bug in the update functionality with `GENERATED ALWAYS AS IDENTITY` therefore `SERIAL` was used. (See [issue](https://github.com/Kamirus/purescript-selda/issues/42)). 54 | 1. As of the time of writing, there was a bug in PureScript with type synonyms therefore code was repeated. (See [issue](https://github.com/purescript/purescript/issues/4105), search for `4105` in the code). 55 | 1. PureScript Payload: 56 | 1. The `Failure` type did not fit for CORS, because it requires a custom header with every request. 57 | 1. Payload does not output validation errors. In order to see them, Payload was patched. (Compare ) (See [issue](https://github.com/hoodunit/purescript-payload/issues/13)) 58 | 1. Validation: 59 | 1. [purescript-simple-json](https://github.com/justinwoo/purescript-simple-json) is used for JSON encoding/decoding. Because the error field is dynamic the error structure is rendered with simple string concatenation (see [src/Server/Shared/Api/Main.purs](./src/Server/Shared/Api/Main.purs)). This could be improved. 60 | 1. Strings are represented by: 61 | 1. `LongString`: Between 1 and 1000 characters. The database type is unrestricted (`TEXT`). 62 | 1. `LowercaseString`: Forces strings to be lowercase, e.g. for tags. The database type is unrestricted and case-insensitive (`CITEXT`). 63 | 1. `ShortString`: Between 1 and 50 characters. The database type is unrestricted (`TEXT`). 64 | 1. In order to safe on boilerplate code, all simple types like `UserId` are coded with `type` instead of `newtype`. 65 | 1. Security: 66 | 1. [purescript-node-jwt](https://github.com/gaku-sei/purescript-node-jwt) is used for token encoding/decoding. Only userId is encoded used. The expiration time is set to 1 hour. 67 | 1. Tests: 68 | 1. Setting `origin` in the tests was not possible (Error message: `Refused to set unsafe header "origin"`). I had to mock the function. 69 | 1. The test case request and response bodies can be found under `test/Server//`. This way, they can be used via *HTTPie* and with automated testing. 70 | 1. Frontend: 71 | 1. [purescript-halogen-realword](https://github.com/thomashoneyman/purescript-halogen-realworld) did not work for update user and post comments. (See [issue](https://github.com/thomashoneyman/purescript-halogen-realworld/issues/78)) 72 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2021 jim108dev 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # PureScript Payload RealWorld Example 2 | 3 | This is a learning project in order to set up a REST API with [PureScript Payload](https://github.com/hoodunit/purescript-payload) and [PostgreSQL](https://www.postgresql.org). The specification follows 4 | 5 | - [RealWorld API Spec](https://github.com/gothinkster/realworld/tree/master/api) 6 | 7 | ## Install 8 | 9 | 1. Install [PureScript](https://www.purescript.org/). 10 | 11 | 1. Install repository 's software: 12 | 13 | 1. Run: 14 | 15 | ```sh 16 | # This repo 17 | git clone https://github.com/jim108dev/purescript-payload-realworld-example.git 18 | 19 | cd purescript-payload-realworld-example 20 | 21 | npm install pg decimal.js xhr2 jsonwebtoken 22 | spago install 23 | spago build 24 | ``` 25 | 26 | ### Development/Test Mode 27 | 28 | Please choose if you want to run the server in development/test (Dev) mode or in production mode (Prod). *Dev* operates with fixed timestamps which is required for the automated tests to run. *Prod* operates with the current system time. 29 | 30 | 1. Database Setup: 31 | 1. Install PostgreSQL. 32 | 1. `sql/CreateDB.sql`: Execute commands which set up a database called `conduit`. 33 | 1. `config/Server/{Dev|Prod}.json`: Change config files according to your db setup. 34 | 1. `sql/Functions.sql`: Execute commands which set up functions/triggers for *Prod*. 35 | 1. `sql/ResetTables.sql`: Activate the current timestamps by uncommenting `-- TIMESTAMP` for *Prod*. This file can be executed with: 36 | 37 | ```sh 38 | spago run -m Test.ResetTables 39 | ``` 40 | 41 | 1. Jwt: `config/Server/Prod.json`: Change the token's secret key for *Prod*. 42 | 43 | 1. Server: `src/Server/Main.purs`: Set the configuration file accordingly. 44 | 45 | 1. Optional: Install [HTTPie](https://httpie.io) and [httpie-jwt-auth](https://github.com/teracyhq/httpie-jwt-auth) for testing via command line. 46 | 47 | 1. Optional: Install a frontend like [Real World Halogen](). 48 | 49 | ## Usage 50 | 51 | 1. Run the server: 52 | 53 | ```sh 54 | spago run 55 | ``` 56 | 57 | 1. [API-SPEC.md](./API-SPEC.md) lists HTTPie test calls to every request. 58 | 59 | 1. Run a frontend. 60 | 61 | ## Development 62 | 63 | 1. Run the unit tests 64 | 65 | ```sh 66 | spago run -m Test.Main 67 | ``` 68 | 69 | [APPROACH.md](./APPROACH.md) contains some comments about the decisions which were made. 70 | -------------------------------------------------------------------------------- /config/Server/Dev.json: -------------------------------------------------------------------------------- 1 | { 2 | "server": { 3 | "port": 3000, 4 | "hostname": "localhost", 5 | "logLevel": "Debug" 6 | }, 7 | "persistence": { 8 | "hostname": "localhost", 9 | "database": "conduit", 10 | "user": "a", 11 | "password": "password", 12 | "impl": "Postgres" 13 | }, 14 | "token": { 15 | "timestamp": "2030-01-01T00:00:00Z", 16 | "secret": "secret" 17 | } 18 | } -------------------------------------------------------------------------------- /config/Server/Prod.json: -------------------------------------------------------------------------------- 1 | { 2 | "server": { 3 | "port": 3000, 4 | "hostname": "localhost", 5 | "logLevel": "Normal" 6 | }, 7 | "persistence": { 8 | "hostname": "localhost", 9 | "database": "conduit", 10 | "user": "a", 11 | "password": "password", 12 | "impl": "Postgres" 13 | }, 14 | "token": { 15 | "secret": "secret" 16 | } 17 | } -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "dependencies": { 3 | "decimal.js": "^10.2.1", 4 | "jsonwebtoken": "^8.5.1", 5 | "pg": "^8.6.0", 6 | "xhr2": "^0.2.1" 7 | } 8 | } 9 | -------------------------------------------------------------------------------- /packages.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to your new Dhall package-set! 3 | 4 | Below are instructions for how to edit this file for most use 5 | cases, so that you don't need to know Dhall to use it. 6 | 7 | ## Use Cases 8 | 9 | Most will want to do one or both of these options: 10 | 1. Override/Patch a package's dependency 11 | 2. Add a package not already in the default package set 12 | 13 | This file will continue to work whether you use one or both options. 14 | Instructions for each option are explained below. 15 | 16 | ### Overriding/Patching a package 17 | 18 | Purpose: 19 | - Change a package's dependency to a newer/older release than the 20 | default package set's release 21 | - Use your own modified version of some dependency that may 22 | include new API, changed API, removed API by 23 | using your custom git repo of the library rather than 24 | the package set's repo 25 | 26 | Syntax: 27 | where `entityName` is one of the following: 28 | - dependencies 29 | - repo 30 | - version 31 | ------------------------------- 32 | let upstream = -- 33 | in upstream 34 | with packageName.entityName = "new value" 35 | ------------------------------- 36 | 37 | Example: 38 | ------------------------------- 39 | let upstream = -- 40 | in upstream 41 | with halogen.version = "master" 42 | with halogen.repo = "https://example.com/path/to/git/repo.git" 43 | 44 | with halogen-vdom.version = "v4.0.0" 45 | with halogen-vdom.dependencies = [ "extra-dependency" ] # halogen-vdom.dependencies 46 | ------------------------------- 47 | 48 | ### Additions 49 | 50 | Purpose: 51 | - Add packages that aren't already included in the default package set 52 | 53 | Syntax: 54 | where `` is: 55 | - a tag (i.e. "v4.0.0") 56 | - a branch (i.e. "master") 57 | - commit hash (i.e. "701f3e44aafb1a6459281714858fadf2c4c2a977") 58 | ------------------------------- 59 | let upstream = -- 60 | in upstream 61 | with new-package-name = 62 | { dependencies = 63 | [ "dependency1" 64 | , "dependency2" 65 | ] 66 | , repo = 67 | "https://example.com/path/to/git/repo.git" 68 | , version = 69 | "" 70 | } 71 | ------------------------------- 72 | 73 | Example: 74 | ------------------------------- 75 | let upstream = -- 76 | in upstream 77 | with benchotron = 78 | { dependencies = 79 | [ "arrays" 80 | , "exists" 81 | , "profunctor" 82 | , "strings" 83 | , "quickcheck" 84 | , "lcg" 85 | , "transformers" 86 | , "foldable-traversable" 87 | , "exceptions" 88 | , "node-fs" 89 | , "node-buffer" 90 | , "node-readline" 91 | , "datetime" 92 | , "now" 93 | ] 94 | , repo = 95 | "https://github.com/hdgarrood/purescript-benchotron.git" 96 | , version = 97 | "v7.0.0" 98 | } 99 | ------------------------------- 100 | -} 101 | let upstream = 102 | https://github.com/purescript/package-sets/releases/download/psc-0.14.1-20210516/packages.dhall sha256:f5e978371d4cdc4b916add9011021509c8d869f4c3f6d0d2694c0e03a85046c8 103 | 104 | in upstream 105 | with payload = 106 | { dependencies = 107 | [ "aff" 108 | , "affjax" 109 | , "console" 110 | , "effect" 111 | , "node-fs" 112 | , "node-fs-aff" 113 | , "node-http" 114 | , "prelude" 115 | , "record" 116 | , "simple-json" 117 | , "stringutils" 118 | , "test-unit" 119 | , "typelevel-prelude" 120 | ] 121 | , repo = "https://github.com/jim108dev/purescript-payload.git" 122 | , version = "master" 123 | } 124 | with postgresql-client = 125 | { dependencies = 126 | [ "aff" 127 | , "argonaut" 128 | , "arrays" 129 | , "assert" 130 | , "bifunctors" 131 | , "bytestrings" 132 | , "datetime" 133 | , "decimals" 134 | , "dotenv" 135 | , "effect" 136 | , "either" 137 | , "enums" 138 | , "exceptions" 139 | , "foldable-traversable" 140 | , "foreign" 141 | , "foreign-generic" 142 | , "foreign-object" 143 | , "identity" 144 | , "integers" 145 | , "js-date" 146 | , "lists" 147 | , "math" 148 | , "maybe" 149 | , "newtype" 150 | , "node-process" 151 | , "nullable" 152 | , "ordered-collections" 153 | , "partial" 154 | , "polyform" 155 | , "polyform-batteries-core" 156 | , "polyform-batteries-env" 157 | , "prelude" 158 | , "psci-support" 159 | , "string-parsers" 160 | , "strings" 161 | , "test-unit" 162 | , "transformers" 163 | , "tuples" 164 | , "typelevel-prelude" 165 | , "validation" 166 | ] 167 | , repo = "https://github.com/jordanmartinez/purescript-postgresql-client.git" 168 | , version = "updateTov0.14.1" 169 | } 170 | with polyform = 171 | { dependencies = 172 | [ "arrays" 173 | , "bifunctors" 174 | , "control" 175 | , "effect" 176 | , "either" 177 | , "enums" 178 | , "functors" 179 | , "identity" 180 | , "invariant" 181 | , "lists" 182 | , "maybe" 183 | , "newtype" 184 | , "parallel" 185 | , "partial" 186 | , "prelude" 187 | , "profunctor" 188 | , "psci-support" 189 | , "quickcheck" 190 | , "quickcheck-laws" 191 | , "record" 192 | , "transformers" 193 | , "tuples" 194 | , "typelevel-prelude" 195 | , "unsafe-coerce" 196 | , "validation" 197 | , "variant" 198 | ] 199 | , repo = "https://github.com/jordanmartinez/purescript-polyform.git" 200 | , version = "updateTov0.14.1" 201 | } 202 | with polyform-batteries-core = 203 | { dependencies = 204 | [ "arrays" 205 | , "decimals" 206 | , "effect" 207 | , "enums" 208 | , "integers" 209 | , "lazy" 210 | , "maybe" 211 | , "numbers" 212 | , "partial" 213 | , "polyform" 214 | , "prelude" 215 | , "psci-support" 216 | , "quickcheck" 217 | , "strings" 218 | , "test-unit" 219 | , "typelevel-prelude" 220 | , "validation" 221 | , "variant" 222 | ] 223 | , repo = "https://github.com/jordanmartinez/purescript-polyform-validators.git" 224 | , version = "updateTov0.14.1" 225 | } 226 | with polyform-batteries-env = 227 | { dependencies = 228 | [ "arrays" 229 | , "identity" 230 | , "maybe" 231 | , "ordered-collections" 232 | , "polyform" 233 | , "polyform-batteries-core" 234 | , "prelude" 235 | , "psci-support" 236 | , "typelevel-prelude" 237 | ] 238 | , repo = "https://github.com/jordanmartinez/batteries-env.git" 239 | , version = "updateTov0.14.1" 240 | } 241 | with selda = 242 | { dependencies = 243 | [ "aff" 244 | , "arrays" 245 | , "bifunctors" 246 | , "console" 247 | , "datetime" 248 | , "dodo-printer" 249 | , "dotenv" 250 | , "effect" 251 | , "either" 252 | , "enums" 253 | , "exceptions" 254 | , "exists" 255 | , "foldable-traversable" 256 | , "foreign" 257 | , "foreign-object" 258 | , "heterogeneous" 259 | , "leibniz" 260 | , "lists" 261 | , "maybe" 262 | , "newtype" 263 | , "node-process" 264 | , "node-sqlite3" 265 | , "ordered-collections" 266 | , "partial" 267 | , "polyform" 268 | , "polyform-batteries-core" 269 | , "polyform-batteries-env" 270 | , "postgresql-client" 271 | , "prelude" 272 | , "record" 273 | , "simple-json" 274 | , "strings" 275 | , "test-unit" 276 | , "transformers" 277 | , "tuples" 278 | , "typelevel-prelude" 279 | , "unsafe-coerce" 280 | , "validation" 281 | , "variant" 282 | ] 283 | , repo = "https://github.com/Kamirus/purescript-selda.git" 284 | , version = "master" 285 | } 286 | with node-jwt = 287 | { dependencies = 288 | [ "aff" 289 | , "aff-promise" 290 | , "console" 291 | , "effect" 292 | , "foreign-generic" 293 | , "newtype" 294 | , "psci-support" 295 | , "options" 296 | ] 297 | , repo = "https://github.com/jim108dev/purescript-node-jwt" 298 | , version = "master" 299 | } 300 | with simple-timestamp = 301 | { dependencies = 302 | [ "console" 303 | , "datetime" 304 | , "effect" 305 | , "foreign" 306 | , "formatters" 307 | , "prelude" 308 | , "psci-support" 309 | , "simple-json" 310 | , "spec" 311 | ] 312 | , repo = "https://github.com/jim108dev/purescript-simple-timestamp" 313 | , version = "master" 314 | } -------------------------------------------------------------------------------- /spago.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to a Spago project! 3 | You can edit this file as you like. 4 | 5 | Need help? See the following resources: 6 | - Spago documentation: https://github.com/purescript/spago 7 | - Dhall language tour: https://docs.dhall-lang.org/tutorials/Language-Tour.html 8 | 9 | When creating a new Spago project, you can use 10 | `spago init --no-comments` or `spago init -C` 11 | to generate this file without the comments in this block. 12 | -} 13 | { name = "my-project" 14 | , dependencies = 15 | [ "aff" 16 | , "affjax" 17 | , "argonaut" 18 | , "arrays" 19 | , "bifunctors" 20 | , "console" 21 | , "control" 22 | , "datetime" 23 | , "effect" 24 | , "either" 25 | , "errors" 26 | , "exceptions" 27 | , "foldable-traversable" 28 | , "foreign" 29 | , "foreign-generic" 30 | , "foreign-object" 31 | , "http-methods" 32 | , "lists" 33 | , "maybe" 34 | , "newtype" 35 | , "node-buffer" 36 | , "node-fs-aff" 37 | , "node-http" 38 | , "node-jwt" 39 | , "node-path" 40 | , "now" 41 | , "nullable" 42 | , "ordered-collections" 43 | , "partial" 44 | , "payload" 45 | , "point-free" 46 | , "postgresql-client" 47 | , "prelude" 48 | , "psci-support" 49 | , "selda" 50 | , "simple-json" 51 | , "simple-timestamp" 52 | , "strings" 53 | , "test-unit" 54 | , "transformers" 55 | , "tuples" 56 | , "typelevel-prelude" 57 | ] 58 | , packages = ./packages.dhall 59 | , sources = [ "src/**/*.purs", "test/**/*.purs" ] 60 | } 61 | -------------------------------------------------------------------------------- /sql/CreateDB.sql: -------------------------------------------------------------------------------- 1 | DROP DATABASE IF EXISTS conduit; 2 | 3 | CREATE DATABASE conduit; 4 | 5 | CREATE USER a WITH ENCRYPTED PASSWORD 'password'; 6 | 7 | GRANT ALL PRIVILEGES ON DATABASE conduit TO a; 8 | 9 | \connect conduit 10 | CREATE EXTENSION IF NOT EXISTS citext; 11 | 12 | CREATE EXTENSION IF NOT EXISTS pgcrypto; 13 | 14 | -------------------------------------------------------------------------------- /sql/Functions.sql: -------------------------------------------------------------------------------- 1 | CREATE OR REPLACE FUNCTION update_updated_at () 2 | RETURNS TRIGGER 3 | AS $$ 4 | BEGIN 5 | NEW.updated_at = now(); 6 | RETURN NEW; 7 | END; 8 | $$ 9 | LANGUAGE 'plpgsql'; 10 | 11 | DROP TRIGGER update_article_updated_at ON "user"; 12 | 13 | CREATE TRIGGER update_article_updated_at 14 | BEFORE UPDATE ON article 15 | FOR EACH ROW 16 | EXECUTE PROCEDURE update_updated_at (); 17 | 18 | DROP TRIGGER update_comment_updated_at ON comment; 19 | 20 | CREATE TRIGGER update_comment_updated_at 21 | BEFORE UPDATE ON comment 22 | FOR EACH ROW 23 | EXECUTE PROCEDURE update_updated_at (); 24 | 25 | -- show triggers 26 | SELECT 27 | event_object_schema AS table_schema, 28 | event_object_table AS table_name, 29 | trigger_schema, 30 | trigger_name, 31 | string_agg(event_manipulation, ',') AS event, 32 | action_timing AS activation, 33 | action_condition AS condition, 34 | action_statement AS definition 35 | FROM 36 | information_schema.triggers 37 | GROUP BY 38 | 1, 39 | 2, 40 | 3, 41 | 4, 42 | 6, 43 | 7, 44 | 8 45 | ORDER BY 46 | table_schema, 47 | table_name; 48 | 49 | -------------------------------------------------------------------------------- /sql/ResetTables.sql: -------------------------------------------------------------------------------- 1 | DROP TABLE IF EXISTS "user" CASCADE; 2 | 3 | CREATE TABLE "user" ( 4 | id SERIAL, -- int GENERATED ALWAYS AS IDENTITY 5 | bio text, 6 | email CITEXT NOT NULL CONSTRAINT email_unique UNIQUE, 7 | image text, 8 | password TEXT NOT NULL, 9 | username CITEXT NOT NULL CONSTRAINT username_unique UNIQUE, 10 | PRIMARY KEY (id) 11 | ); 12 | 13 | DROP TABLE IF EXISTS article CASCADE; 14 | 15 | CREATE TABLE article ( 16 | author_id int NOT NULL, 17 | body text NOT NULL, 18 | created_at timestamp with time zone DEFAULT '2016-02-18 03:22:56', -- CURRENT_TIMESTAMP, 19 | description text NOT NULL, 20 | id SERIAL, -- int GENERATED ALWAYS AS IDENTITY, 21 | slug CITEXT NOT NULL CONSTRAINT slug_unique UNIQUE, 22 | tag_list CITEXT[] NOT NULL, 23 | title CITEXT NOT NULL, 24 | updated_at timestamp with time zone DEFAULT '2016-02-18 03:22:56', --CURRENT_TIMESTAMP, 25 | PRIMARY KEY (id), 26 | CONSTRAINT author_exists FOREIGN KEY (author_id) REFERENCES "user" (id) ON DELETE CASCADE 27 | ); 28 | 29 | DROP TABLE IF EXISTS comment CASCADE; 30 | 31 | CREATE TABLE comment ( 32 | id SERIAL, -- int GENERATED ALWAYS AS IDENTITY, 33 | created_at timestamp with time zone DEFAULT '2016-02-18 03:22:56', --CURRENT_TIMESTAMP, 34 | updated_at timestamp with time zone DEFAULT '2016-02-18 03:22:56', --CURRENT_TIMESTAMP, 35 | body text NOT NULL, 36 | article_id int NOT NULL, 37 | author_id int NOT NULL, 38 | PRIMARY KEY (id), 39 | FOREIGN KEY (author_id) REFERENCES "user" (id) ON DELETE CASCADE, 40 | FOREIGN KEY (article_id) REFERENCES "article" (id) ON DELETE CASCADE 41 | ); 42 | 43 | DROP TABLE IF EXISTS FOLLOWING CASCADE; 44 | 45 | CREATE TABLE FOLLOWING ( 46 | follower_id int NOT NULL, 47 | followee_id int NOT NULL CONSTRAINT follower_not_followee CHECK (followee_id <> follower_id), 48 | CONSTRAINT following_unique PRIMARY KEY (follower_id, followee_id), 49 | CONSTRAINT follower_exists FOREIGN KEY (follower_id) REFERENCES "user" (id) ON DELETE CASCADE, 50 | CONSTRAINT followee_exists FOREIGN KEY (followee_id) REFERENCES "user" (id) ON DELETE CASCADE 51 | ); 52 | 53 | DROP TABLE IF EXISTS favorited CASCADE; 54 | 55 | CREATE TABLE favorited ( 56 | user_id int NOT NULL, 57 | article_id int NOT NULL, 58 | CONSTRAINT favorited_unique PRIMARY KEY (user_id, article_id), 59 | CONSTRAINT user_exists FOREIGN KEY (user_id) REFERENCES "user" (id) ON DELETE CASCADE, 60 | CONSTRAINT article_exists FOREIGN KEY (article_id) REFERENCES "article" (id) ON DELETE CASCADE 61 | ); 62 | 63 | -------------------------------------------------------------------------------- /sql/Sandbox.sql: -------------------------------------------------------------------------------- 1 | SELECT 2 | ARRAY (t)::text[] AS tagList 3 | FROM ( SELECT DISTINCT 4 | UNNEST(article_0.tag_list) AS tagList 5 | FROM 6 | article article_0 7 | ORDER BY 8 | 1 ASC) sub_q0 (t); 9 | 10 | -------------------------------------------------------------------------------- /src/Main.purs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude 4 | import Effect (Effect) 5 | import Server.Main (main) as Server 6 | 7 | main :: Effect Unit 8 | main = Server.main 9 | -------------------------------------------------------------------------------- /src/Server/Article/Api/Interface/Spec.purs: -------------------------------------------------------------------------------- 1 | module Server.Article.Api.Interface.Spec where 2 | 3 | import Payload.Spec (DELETE, GET, POST, PUT) 4 | import Payload.Spec (Routes) as Payload 5 | import Server.Article.Api.Type.CreateDto (CreateDto) 6 | import Server.Article.Api.Type.Misc (MultipleDto, Param, SingleDto, TagsDto) 7 | import Server.Article.Api.Type.UpdateDto (UpdateDto) 8 | import Server.Article.Type.Misc (FullQuery, RangeQuery) 9 | import Server.Shared.Api.Interface.Spec (AuthGuard, OptionalGuard, CorsGuard) 10 | 11 | type Routes 12 | = Payload.Routes "/api" 13 | { guards :: CorsGuard 14 | , list :: 15 | GET "/articles?tag=&author=&favorited=&limit=&offset=" 16 | { guards :: OptionalGuard 17 | , query :: FullQuery 18 | , response :: MultipleDto 19 | } 20 | , feed :: 21 | GET "/articles/feed?limit=&offset=" 22 | { guards :: AuthGuard 23 | , query :: RangeQuery 24 | , response :: MultipleDto 25 | } 26 | , get :: 27 | GET "/articles/" 28 | { guards :: OptionalGuard 29 | , params :: Param 30 | , response :: SingleDto 31 | } 32 | , create :: 33 | POST "/articles" 34 | { body :: CreateDto 35 | , guards :: AuthGuard 36 | , response :: SingleDto 37 | } 38 | , update :: 39 | PUT "/articles/" 40 | { body :: UpdateDto 41 | , guards :: AuthGuard 42 | , params :: Param 43 | , response :: SingleDto 44 | } 45 | , delete :: 46 | DELETE "/articles/" 47 | { guards :: AuthGuard 48 | , params :: Param 49 | } 50 | , favorite :: 51 | POST "/articles//favorite" 52 | { guards :: AuthGuard 53 | , params :: Param 54 | , response :: SingleDto 55 | } 56 | , unfavorite :: 57 | DELETE "/articles//favorite" 58 | { guards :: AuthGuard 59 | , params :: Param 60 | , response :: SingleDto 61 | } 62 | , getTags :: 63 | GET "/tags" 64 | { response :: TagsDto 65 | } 66 | } 67 | -------------------------------------------------------------------------------- /src/Server/Article/Api/Main.purs: -------------------------------------------------------------------------------- 1 | module Server.Article.Api.Main where 2 | 3 | import Prelude 4 | import Data.Bifunctor (bimap) 5 | import Data.Either (Either(..)) 6 | import Effect.Aff (Aff) 7 | import Payload.ResponseTypes (Empty(..), Response) 8 | import Payload.Server.Response (notFound, ok, unprocessableEntity) 9 | import Server.Article.Api.Type.CreateDto (CreateDto, unwrapCreateDto) 10 | import Server.Article.Api.Type.Misc (MultipleDto, Param, SingleDto, TagsDto, mkMultipleDto, mkSingleDto, mkTagsDto) 11 | import Server.Article.Api.Type.UpdateDto (UpdateDto, unwrapUpdateDto) 12 | import Server.Article.Interface.Persistence (Handle) as Persistence 13 | import Server.Article.Persistence.Postgres.Main as Postgres 14 | import Server.Article.Type.Misc (FullQuery, InputError(..), RangeQuery) 15 | import Server.Shared.Api.Main (setHeaders, renderErrorEntity, renderErrorMessage) 16 | import Server.Shared.Api.Type.Misc (AuthGuard, CorsGuard, OptionalGuard, TResponse) 17 | import Server.Shared.Interface.Persistence (Handle) 18 | import Server.Shared.Type.Misc (Pool(..)) 19 | 20 | mkHandle :: Handle -> _ 21 | mkHandle h = 22 | { create: create h 23 | , list: list h 24 | , delete: delete h 25 | , favorite: favorite h 26 | , feed: feed h 27 | , get: get h 28 | , getTags: getTags h 29 | , unfavorite: unfavorite h 30 | , update: update h 31 | } 32 | 33 | next :: Handle -> Persistence.Handle 34 | next h = case h.pool of 35 | PostgresPool pool -> Postgres.mkHandle pool 36 | 37 | list :: Handle -> { guards :: OptionalGuard, query :: FullQuery } -> Aff (TResponse MultipleDto) 38 | list h { guards: g, query: q } = 39 | setHeaders g.origin 40 | <$> bimap renderError (ok <<< mkMultipleDto) 41 | <$> Right 42 | <$> (next h).search g.maybeUserId q 43 | 44 | feed :: Handle -> { query :: RangeQuery, guards :: AuthGuard } -> Aff (TResponse MultipleDto) 45 | feed h { query: q, guards: g } = 46 | setHeaders g.origin 47 | <$> bimap renderError (ok <<< mkMultipleDto) 48 | <$> Right 49 | <$> (next h).searchMostRecentFromFollowees g.userId q 50 | 51 | get :: Handle -> { guards :: OptionalGuard, params :: Param } -> Aff (TResponse SingleDto) 52 | get h { guards: g, params: p } = 53 | setHeaders g.origin 54 | <$> bimap renderError (ok <<< mkSingleDto) 55 | <$> (next h).findOne g.maybeUserId p.slug 56 | 57 | create :: Handle -> { body :: CreateDto, guards :: AuthGuard } -> Aff (TResponse SingleDto) 58 | create h { body: b, guards: g } = 59 | setHeaders g.origin 60 | <$> bimap renderError (ok <<< mkSingleDto) 61 | <$> (next h).insert (unwrapCreateDto b) g.userId 62 | 63 | update :: Handle -> { body :: UpdateDto, params :: Param, guards :: AuthGuard } -> Aff (TResponse SingleDto) 64 | update h { body: b, params: p, guards: g } = 65 | setHeaders g.origin 66 | <$> bimap renderError (ok <<< mkSingleDto) 67 | <$> (next h).update (unwrapUpdateDto b) p.slug g.userId 68 | 69 | favorite :: Handle -> { params :: Param, guards :: AuthGuard } -> Aff (TResponse SingleDto) 70 | favorite h { params: p, guards: g } = 71 | setHeaders g.origin 72 | <$> bimap renderError (ok <<< mkSingleDto) 73 | <$> (next h).insertFavorite p.slug g.userId 74 | 75 | unfavorite :: Handle -> { params :: Param, guards :: AuthGuard } -> Aff (TResponse SingleDto) 76 | unfavorite h { params: p, guards: g } = 77 | setHeaders g.origin 78 | <$> bimap renderError (ok <<< mkSingleDto) 79 | <$> (next h).deleteFavorite p.slug g.userId 80 | 81 | delete :: Handle -> { params :: Param, guards :: AuthGuard } -> Aff (TResponse Empty) 82 | delete h { params: p, guards: g } = 83 | setHeaders g.origin 84 | <$> bimap renderError (\_ -> ok Empty) 85 | <$> (next h).delete p.slug g.userId 86 | 87 | getTags :: Handle -> { guards :: CorsGuard } -> Aff (TResponse TagsDto) 88 | getTags h { guards: g } = 89 | setHeaders g.origin 90 | <$> bimap renderError (ok <<< mkTagsDto) 91 | <$> Right 92 | <$> (next h).findTags 93 | 94 | renderError :: InputError -> Response String 95 | renderError SLUG_EXISTS = unprocessableEntity $ renderErrorEntity "slug" "exists" 96 | renderError TITLE_EXISTS = unprocessableEntity $ renderErrorEntity "title" "exists" 97 | renderError NOT_FOUND = notFound $ renderErrorMessage "article not found" 98 | renderError FAVORITED_EXISTS = unprocessableEntity $ renderErrorEntity "slug" "exists" 99 | renderError SLUG_CREATION_FAILED = unprocessableEntity $ renderErrorEntity "title" "cannot be converted to slug" 100 | -------------------------------------------------------------------------------- /src/Server/Article/Api/Type/CreateDto.purs: -------------------------------------------------------------------------------- 1 | module Server.Article.Api.Type.CreateDto where 2 | 3 | import Prelude 4 | 5 | import Data.Bifunctor (lmap) 6 | import Data.Eq.Generic (genericEq) 7 | import Data.Generic.Rep (class Generic) 8 | import Data.Show.Generic (genericShow) 9 | import Foreign.Class (class Decode, class Encode) 10 | import Foreign.Generic (defaultOptions, genericDecode, genericEncode) 11 | import Payload.Server.DecodeBody (class DecodeBody) 12 | import Server.Article.Type.Misc (Raw) 13 | import Server.Shared.Api.Main (renderJsonErrors) 14 | import Simple.JSON as SJ 15 | 16 | newtype CreateDto 17 | = CreateDto { article :: Raw } 18 | 19 | derive instance genericCreateDto :: Generic CreateDto _ 20 | 21 | instance showCreateDto :: Show CreateDto where 22 | show = genericShow 23 | 24 | instance eqCreateDto :: Eq CreateDto where 25 | eq = genericEq 26 | 27 | instance decodeCreateDto :: Decode CreateDto where 28 | decode = genericDecode $ defaultOptions { unwrapSingleConstructors = true } 29 | 30 | instance encodeCreateDto :: Encode CreateDto where 31 | encode = genericEncode $ defaultOptions { unwrapSingleConstructors = true } 32 | 33 | derive newtype instance readForeignCreateDto :: SJ.ReadForeign CreateDto 34 | 35 | derive newtype instance writeForeignCreateDto :: SJ.WriteForeign CreateDto 36 | 37 | instance decodeBodyCreateDto :: SJ.ReadForeign CreateDto => DecodeBody CreateDto where 38 | decodeBody = lmap renderJsonErrors <<< SJ.readJSON 39 | 40 | wrapCreateDto :: Raw -> CreateDto 41 | wrapCreateDto x = CreateDto { article: x } 42 | 43 | unwrapCreateDto :: CreateDto -> Raw 44 | unwrapCreateDto (CreateDto { article: x }) = x 45 | -------------------------------------------------------------------------------- /src/Server/Article/Api/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Article.Api.Type.Misc where 2 | 3 | import Prelude 4 | 5 | import Data.Array (length) 6 | import Data.Either (Either) 7 | import Data.Nullable (Nullable, toNullable) 8 | import Payload.ResponseTypes (Failure, Response) as P 9 | import Server.Article.Type.Misc (Article) 10 | import Server.Shared.Api.Type.Misc (ArticleParam) 11 | import Shared.Type.Misc (Bio, Body, CreatedAt, Description, Favorited, FavoritesCount, Following, Image, Slug, Tag, Title, Username, UpdatedAt) 12 | 13 | type MultipleDto 14 | = { articles :: Array NullableArticle 15 | , articlesCount :: Int 16 | } 17 | 18 | mkMultipleDto :: Array Article -> MultipleDto 19 | mkMultipleDto articles = 20 | { articles: mkNullableArticle <$> articles 21 | , articlesCount: length articles 22 | } 23 | 24 | type SingleDto 25 | = { article :: NullableArticle 26 | } 27 | 28 | type NullableArticle 29 | = { author :: 30 | { bio :: Nullable Bio 31 | , following :: Following 32 | , image :: Nullable Image 33 | , username :: Username 34 | } 35 | , body :: Body 36 | , createdAt :: CreatedAt 37 | , description :: Description 38 | , favorited :: Favorited 39 | , favoritesCount :: FavoritesCount 40 | , slug :: Slug 41 | , tagList :: Array Tag 42 | , title :: Title 43 | , updatedAt :: UpdatedAt 44 | } 45 | 46 | mkNullableArticle :: Article -> NullableArticle 47 | mkNullableArticle a = 48 | { author: 49 | { bio: toNullable a.author.bio 50 | , following: a.author.following 51 | , image: toNullable a.author.image 52 | , username: a.author.username 53 | } 54 | , body: a.body 55 | , createdAt: a.createdAt 56 | , description: a.description 57 | , favorited: a.favorited 58 | , favoritesCount: a.favoritesCount 59 | , slug: a.slug 60 | , tagList: a.tagList 61 | , title: a.title 62 | , updatedAt: a.updatedAt 63 | } 64 | 65 | mkSingleDto :: Article -> SingleDto 66 | mkSingleDto a = { article: mkNullableArticle a } 67 | 68 | type TagsDto 69 | = { tags :: Array Tag 70 | } 71 | 72 | mkTagsDto :: Array Tag -> TagsDto 73 | mkTagsDto = { tags: _ } 74 | 75 | 76 | type Param 77 | = ArticleParam 78 | -------------------------------------------------------------------------------- /src/Server/Article/Api/Type/UpdateDto.purs: -------------------------------------------------------------------------------- 1 | module Server.Article.Api.Type.UpdateDto where 2 | 3 | import Prelude 4 | 5 | import Data.Bifunctor (lmap) 6 | import Data.Eq.Generic (genericEq) 7 | import Data.Generic.Rep (class Generic) 8 | import Data.Show.Generic (genericShow) 9 | import Payload.Server.DecodeBody (class DecodeBody) 10 | import Server.Article.Type.Misc (Patch) 11 | import Server.Shared.Api.Main (renderJsonErrors) 12 | import Simple.JSON as SJ 13 | 14 | newtype UpdateDto 15 | = UpdateDto { article :: Patch } 16 | 17 | derive instance genericUpdateDto :: Generic UpdateDto _ 18 | 19 | instance showUpdateDto :: Show UpdateDto where 20 | show = genericShow 21 | 22 | instance eqUpdateDto :: Eq UpdateDto where 23 | eq = genericEq 24 | 25 | {- 26 | instance decodeUpdateDto :: Decode UpdateDto where 27 | decode = genericDecode $ defaultOptions { unwrapSingleConstructors = true } 28 | 29 | instance encodeUpdateDto :: Encode UpdateDto where 30 | encode = genericEncode $ defaultOptions { unwrapSingleConstructors = true } 31 | -} 32 | derive newtype instance readForeignUpdateDto :: SJ.ReadForeign UpdateDto 33 | derive newtype instance writeForeignUpdateDto :: SJ.WriteForeign UpdateDto 34 | 35 | instance decodeBodyUpdateDto :: SJ.ReadForeign UpdateDto => DecodeBody UpdateDto where 36 | decodeBody = lmap renderJsonErrors <<< SJ.readJSON 37 | 38 | wrapUpdateDto :: Patch -> UpdateDto 39 | wrapUpdateDto x = UpdateDto { article: x } 40 | 41 | unwrapUpdateDto :: UpdateDto -> Patch 42 | unwrapUpdateDto (UpdateDto { article: x }) = x 43 | -------------------------------------------------------------------------------- /src/Server/Article/Interface/Persistence.purs: -------------------------------------------------------------------------------- 1 | module Server.Article.Interface.Persistence where 2 | 3 | import Data.Either (Either) 4 | import Data.Maybe (Maybe) 5 | import Effect.Aff (Aff) 6 | import Server.Article.Type.Misc (Article, FullQuery, InputError, Patch, RangeQuery, Raw) 7 | import Shared.Type.Misc (FollowerId, Slug, Tag, UserId) 8 | 9 | type Handle 10 | = { delete :: Slug -> UserId -> Aff (Either InputError Slug) 11 | , deleteFavorite :: Slug -> UserId -> Aff (Either InputError Article) 12 | , findOne :: Maybe FollowerId -> Slug -> Aff (Either InputError Article) 13 | , findTags :: Aff (Array Tag) 14 | , insert :: Raw -> UserId -> Aff (Either InputError Article) 15 | , insertFavorite :: Slug -> UserId -> Aff (Either InputError Article) 16 | , search :: Maybe FollowerId -> FullQuery -> Aff (Array Article) 17 | , searchMostRecentFromFollowees :: FollowerId -> RangeQuery -> Aff (Array Article) 18 | , update :: Patch -> Slug -> UserId -> Aff (Either InputError Article) 19 | } 20 | -------------------------------------------------------------------------------- /src/Server/Article/Persistence/Postgres/Main.purs: -------------------------------------------------------------------------------- 1 | module Server.Article.Persistence.Postgres.Main where 2 | 3 | import Prelude 4 | import Data.Either (Either(..)) 5 | import Data.Maybe (Maybe(..), maybe) 6 | import Database.PostgreSQL (Pool) 7 | import Effect.Aff (Aff) 8 | import Selda (Col, Table(..), aggregate, asc, count, distinct, innerJoin, isNull, leftJoin, limit, lit, not_, orderBy, restrict, selectFrom, selectFrom_, (.==)) 9 | import Selda (FullQuery) as S 10 | import Selda.PG (generateSeries, litPG) 11 | import Selda.PG.Class (deleteFrom, insert1_, query) 12 | import Selda.PG.Class (update) as S 13 | import Selda.Query.Class (runSelda) 14 | import Selda.Query.Type (Order(..)) 15 | import Server.Article.Interface.Persistence (Handle) 16 | import Server.Article.Persistence.Postgres.Type.Misc (DbOutputCols) 17 | import Server.Article.Persistence.Postgres.Validation (validateArray, validateSingle, validateSlug, validateTags) 18 | import Server.Article.Type.Misc (Article, FullQuery, Id, InputError(..), Patch, RangeQuery, Raw) 19 | import Server.Shared.Persistence.Postgres.Main (any, toArrayTextArray, toTextArray, logQuery, subQuery, withConnection, unnest) 20 | import Server.Shared.Persistence.Type.Misc (articleTable, favoritedTable, followingTable, unitTable, userTable) 21 | import Server.Shared.Util.Selda (query1_) 22 | import Shared.Type.LowercaseString (fromString) 23 | import Shared.Type.Misc (FollowerId, Slug, Tag, UserId) 24 | import Shared.Type.ShortString (toString) 25 | 26 | mkHandle :: Pool -> Handle 27 | mkHandle p = 28 | { delete: delete p 29 | , deleteFavorite: deleteFavorite p 30 | , findOne: findOne p 31 | , findTags: findTags p 32 | , insert: insert p 33 | , insertFavorite: insertFavorite p 34 | , search: search p 35 | , searchMostRecentFromFollowees: searchMostRecentFromFollowees p 36 | , update: update p 37 | } 38 | 39 | selectByQuery :: forall s. Maybe FollowerId -> FullQuery -> S.FullQuery s (DbOutputCols s) 40 | selectByQuery followerId q = 41 | selectFrom_ (select followerId) \a -> do 42 | maybe (pure unit) (\author -> restrict $ a.username .== litPG author) q.author 43 | maybe (pure unit) 44 | ( \favoritedByUsername -> do 45 | fa <- innerJoin favoritedTable \fa -> (a.id .== fa.article_id) 46 | u <- innerJoin userTable \u -> (fa.user_id .== u.id) && (u.username .== litPG favoritedByUsername) 47 | pure unit 48 | ) 49 | q.favorited 50 | maybe (pure unit) (\tag -> restrict $ litPG tag .== (any a.tagList)) q.tag 51 | orderBy Desc a.updatedAt 52 | maybe (pure unit) (\i -> limit i) q.limit 53 | pure a 54 | 55 | search :: Pool -> Maybe FollowerId -> FullQuery -> Aff (Array Article) 56 | search pool followerId q = 57 | withConnection pool (\conn -> runSelda conn $ query $ selectByQuery followerId q) 58 | >>= validateArray 59 | 60 | selectMostRecentFromFollowees :: forall s. FollowerId -> RangeQuery -> S.FullQuery s (DbOutputCols s) 61 | selectMostRecentFromFollowees followerId q = 62 | distinct 63 | $ selectFrom_ (select (Just followerId)) \a -> do 64 | fo <- innerJoin followingTable \fo -> (litPG followerId .== fo.follower_id) && (a.authorId .== fo.followee_id) 65 | orderBy Desc a.updatedAt 66 | maybe (pure unit) (\i -> limit i) q.limit 67 | pure a 68 | 69 | searchMostRecentFromFollowees :: Pool -> FollowerId -> RangeQuery -> Aff (Array Article) 70 | searchMostRecentFromFollowees pool followerId q = 71 | withConnection pool (\conn -> runSelda conn $ query $ selectMostRecentFromFollowees followerId q) 72 | >>= validateArray 73 | 74 | findOne :: Pool -> Maybe FollowerId -> Slug -> Aff (Either InputError Article) 75 | findOne pool followerId slug = 76 | withConnection pool 77 | (\conn -> runSelda conn $ query1_ $ selectBySlug slug followerId) 78 | >>= validateSingle 79 | 80 | selectBySlug :: forall s. Slug -> Maybe UserId -> S.FullQuery s (DbOutputCols s) 81 | selectBySlug slug followerId = 82 | selectFrom_ (select followerId) \s -> do 83 | restrict $ s.slug .== litPG slug 84 | pure s 85 | 86 | countFavorites :: forall s. Col s Id -> S.FullQuery s ({ value :: Col s Int }) 87 | countFavorites id = 88 | aggregate 89 | $ selectFrom favoritedTable \f -> do 90 | restrict $ f.article_id .== id 91 | pure { value: count f.article_id } 92 | 93 | select :: forall s. Maybe FollowerId -> S.FullQuery s (DbOutputCols s) 94 | select followerId = 95 | selectFrom articleTable \a -> do 96 | u <- innerJoin userTable \u -> u.id .== a.author_id 97 | fo <- 98 | leftJoin followingTable \fo -> 99 | fo.followee_id .== u.id 100 | && maybe (lit false) (\id -> fo.follower_id .== litPG id) followerId 101 | fa <- 102 | leftJoin favoritedTable \fa -> 103 | fa.article_id .== a.id 104 | && maybe (lit false) (\id -> fa.user_id .== litPG id) followerId 105 | pure 106 | { bio: u.bio 107 | , body: a.body 108 | , createdAt: a.created_at 109 | , description: a.description 110 | , favorited: not_ $ isNull fa.user_id 111 | , favoritesCount: subQuery (countFavorites a.id) 112 | , following: not_ $ isNull fo.follower_id 113 | , id: a.id 114 | , image: u.image 115 | , slug: a.slug 116 | , tagList: toTextArray a.tag_list 117 | , title: a.title 118 | , updatedAt: a.updated_at 119 | , username: u.username 120 | , authorId: u.id 121 | } 122 | 123 | insert :: Pool -> Raw -> UserId -> Aff (Either InputError Article) 124 | insert pool r userId = case fromString (toString r.title) of 125 | Left e -> pure $ Left SLUG_CREATION_FAILED 126 | Right slug -> 127 | withConnection pool 128 | ( \conn -> 129 | runSelda conn do 130 | insert1_ articleTable 131 | { author_id: userId 132 | , body: r.body 133 | , description: r.description 134 | , slug 135 | , tag_list: r.tagList 136 | , title: r.title 137 | } 138 | query1_ $ selectBySlug slug (Just userId) 139 | ) 140 | >>= validateSingle 141 | 142 | update :: Pool -> Patch -> Slug -> UserId -> Aff (Either InputError Article) 143 | update pool p slug userId = case p.title of 144 | Nothing -> update' pool p slug slug userId 145 | Just newTitle -> case fromString (toString newTitle) of 146 | Left e -> pure $ Left SLUG_CREATION_FAILED 147 | Right newSlug -> update' pool p slug newSlug userId 148 | 149 | update' :: Pool -> Patch -> Slug -> Slug -> UserId -> Aff (Either InputError Article) 150 | update' pool p slug newSlug userId = 151 | withConnection pool 152 | ( \conn -> 153 | runSelda conn do 154 | S.update articleTable 155 | (\r -> r.slug .== litPG slug) 156 | ( \r -> 157 | r 158 | { body = 159 | case p.body of 160 | Nothing -> r.body 161 | Just defined -> litPG defined 162 | , description = 163 | case p.description of 164 | Nothing -> r.description 165 | Just defined -> litPG defined 166 | , title = 167 | case p.title of 168 | Nothing -> r.title 169 | Just defined -> litPG defined 170 | , slug = litPG newSlug 171 | } 172 | ) 173 | query1_ $ selectBySlug newSlug (Just userId) 174 | ) 175 | >>= validateSingle 176 | 177 | insertFavorite :: Pool -> Slug -> UserId -> Aff (Either InputError Article) 178 | insertFavorite pool slug userId = 179 | withConnection pool 180 | ( \conn -> 181 | runSelda conn do 182 | { id: articleId } <- query1_ $ selectBySlug slug (Just userId) 183 | insert1_ favoritedTable { article_id: articleId, user_id: userId } 184 | query1_ $ selectBySlug slug (Just userId) 185 | ) 186 | >>= validateSingle 187 | 188 | deleteFavorite :: Pool -> Slug -> UserId -> Aff (Either InputError Article) 189 | deleteFavorite pool slug userId = 190 | withConnection pool 191 | ( \conn -> 192 | runSelda conn do 193 | { id: articleId } <- query1_ $ selectBySlug slug (Just userId) 194 | deleteFrom favoritedTable (\r -> (litPG articleId .== r.article_id) && (litPG userId .== r.user_id)) 195 | query1_ $ selectBySlug slug (Just userId) 196 | ) 197 | >>= validateSingle 198 | 199 | delete :: Pool -> Slug -> UserId -> Aff (Either InputError Slug) 200 | delete pool slug userId = 201 | withConnection pool 202 | ( \conn -> 203 | runSelda conn do 204 | a <- query1_ $ selectBySlug slug (Just userId) 205 | deleteFrom articleTable (\r -> litPG a.id .== r.id) 206 | pure a.slug 207 | ) 208 | >>= validateSlug 209 | 210 | selectDistinctTagLists :: forall s. S.FullQuery s { tagList :: Col s (Array Tag) } 211 | selectDistinctTagLists = 212 | distinct 213 | $ selectFrom articleTable \a -> do 214 | let 215 | tagList = unnest a.tag_list 216 | orderBy asc tagList 217 | pure { tagList } 218 | 219 | selectTags :: forall s. S.FullQuery s { tags :: Col s (Array Tag) } 220 | selectTags = 221 | selectFrom unitTable \_ -> 222 | pure 223 | { tags: toArrayTextArray selectDistinctTagLists 224 | } 225 | 226 | findTags :: Pool -> Aff (Array Tag) 227 | findTags pool = 228 | withConnection pool (\conn -> runSelda conn $ query selectTags) 229 | >>= validateTags 230 | -------------------------------------------------------------------------------- /src/Server/Article/Persistence/Postgres/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Article.Persistence.Postgres.Type.Misc where 2 | 3 | import Prelude 4 | import Data.DateTime.Instant (Instant, toDateTime) 5 | import Data.Maybe (Maybe) 6 | import Selda (Col) 7 | import Server.Article.Type.Misc (Id, Article) 8 | import Shared.Type.Misc (Bio, Body, Description, Favorited, FavoritesCount, Following, Identity, Image, Slug, Tag, Title, UserId, Username) 9 | import Timestamp (Timestamp(..)) 10 | 11 | type Template col 12 | = ( bio :: col (Maybe Bio) 13 | , body :: col Body 14 | , createdAt :: col Instant 15 | , description :: col Description 16 | , favorited :: col Favorited 17 | , favoritesCount :: col FavoritesCount 18 | , following :: col Following 19 | , id :: col Id 20 | , image :: col (Maybe Image) 21 | , title :: col Title 22 | , slug :: col Slug 23 | , tagList :: col (Array Tag) 24 | , updatedAt :: col Instant 25 | , username :: col Username 26 | , authorId :: col UserId 27 | ) 28 | 29 | type DbOutputCols s 30 | = { | Template (Col s) } 31 | 32 | type DbOutput 33 | = { | Template Identity } 34 | 35 | mkArticle :: DbOutput -> Article 36 | mkArticle r = 37 | { author: 38 | { bio: r.bio 39 | , following: r.following 40 | , image: r.image 41 | , username: r.username 42 | } 43 | , body: r.body 44 | , createdAt: Timestamp $ toDateTime r.createdAt 45 | , description: r.description 46 | , favorited: r.favorited 47 | , favoritesCount: r.favoritesCount 48 | , slug: r.slug 49 | , tagList: r.tagList 50 | , title: r.title 51 | , updatedAt: Timestamp $ toDateTime r.updatedAt 52 | } 53 | -------------------------------------------------------------------------------- /src/Server/Article/Persistence/Postgres/Validation.purs: -------------------------------------------------------------------------------- 1 | module Server.Article.Persistence.Postgres.Validation where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Except (throwError) 6 | import Data.Array (head) 7 | import Data.Either (Either(..)) 8 | import Data.Maybe (Maybe(..)) 9 | import Database.PostgreSQL (PGError(..)) 10 | import Effect.Aff (Aff) 11 | import Effect.Exception (error) 12 | import Server.Article.Persistence.Postgres.Type.Misc (DbOutput, mkArticle) 13 | import Server.Article.Type.Misc (Article, InputError(..)) 14 | import Shared.Type.Misc (Tag) 15 | 16 | validateArray :: Either PGError (Array DbOutput) -> Aff (Array Article) 17 | validateArray result = do 18 | case result of 19 | Left e -> throwError $ error $ show e 20 | Right rows -> pure $ mkArticle <$> rows 21 | 22 | validateSlug :: forall a. Either PGError a -> Aff (Either InputError a) 23 | validateSlug result = do 24 | case result of 25 | Left e -> case e of 26 | -- | `query1_` Throws `ConversionError ∷ PGError` is case of no results. 27 | ConversionError _ -> pure $ Left NOT_FOUND 28 | otherwise -> throwError $ error $ show e 29 | Right a -> pure $ Right a 30 | 31 | validateTags :: Either PGError (Array { tags :: Array Tag }) -> Aff (Array Tag) 32 | validateTags result = do 33 | case result of 34 | Left e -> throwError $ error $ show e 35 | Right rows -> case head rows of 36 | Nothing -> pure [] 37 | Just row -> pure row.tags 38 | 39 | validateSingle :: Either PGError (DbOutput) -> Aff (Either InputError Article) 40 | validateSingle result = do 41 | case result of 42 | Left e -> case e of 43 | IntegrityError detail -> case detail.constraint of 44 | "slug_unique" -> pure $ Left SLUG_EXISTS 45 | "favorited_unique" -> pure $ Left FAVORITED_EXISTS 46 | otherwise -> throwError $ error $ show e 47 | -- | `query1_` Throws `ConversionError ∷ PGError` is case of no results. 48 | ConversionError _ -> pure $ Left NOT_FOUND 49 | otherwise -> throwError $ error $ show e 50 | Right a -> pure $ Right $ mkArticle a 51 | -------------------------------------------------------------------------------- /src/Server/Article/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Article.Type.Misc where 2 | 3 | import Data.Maybe (Maybe, fromMaybe) 4 | import Shared.Type.Misc (ArticleId, AuthorTemplate, Body, CreatedAt, Description, Favorited, FavoritesCount, Identity, Limit, Offset, Slug, Tag, Title, UpdatedAt, Username) 5 | 6 | type RawTemplate col 7 | = ( body :: col Body 8 | , description :: col Description 9 | , tagList :: col (Array Tag) 10 | , title :: col Title 11 | ) 12 | 13 | --type Raw 14 | -- = { | RawTemplate Identity } 15 | -- not possible because of https://github.com/purescript/purescript/issues/4105 16 | type Raw 17 | = { body :: Body 18 | , description :: Description 19 | , tagList :: Array Tag 20 | , title :: Title 21 | } 22 | 23 | type Template col 24 | = ( author :: { | AuthorTemplate col } 25 | , body :: col Body 26 | , description :: col Description 27 | , tagList :: col (Array Tag) 28 | , title :: col Title 29 | , createdAt :: col CreatedAt 30 | , favorited :: col Favorited 31 | , favoritesCount :: col FavoritesCount 32 | , slug :: col Slug 33 | , updatedAt :: col UpdatedAt 34 | ) 35 | 36 | type Article 37 | = { | Template Identity } 38 | 39 | type FullQuery 40 | = { author :: Maybe Username 41 | , favorited :: Maybe Username 42 | , limit :: Maybe Limit 43 | , offset :: Maybe Offset 44 | , tag :: Maybe Tag 45 | } 46 | 47 | type Patch 48 | = { body :: Maybe Body 49 | , description :: Maybe Description 50 | , title :: Maybe Title 51 | } 52 | 53 | mkRawFromPatch :: Article -> Patch -> Raw 54 | mkRawFromPatch f p = 55 | { body: fromMaybe f.body p.body 56 | , description: fromMaybe f.description p.description 57 | , title: fromMaybe f.title p.title 58 | , tagList: f.tagList 59 | } 60 | 61 | type RangeQuery 62 | = { limit :: Maybe Limit 63 | , offset :: Maybe Offset 64 | } 65 | 66 | data InputError 67 | = SLUG_EXISTS 68 | | TITLE_EXISTS 69 | | NOT_FOUND 70 | | FAVORITED_EXISTS 71 | | SLUG_CREATION_FAILED 72 | 73 | type Id 74 | = ArticleId 75 | -------------------------------------------------------------------------------- /src/Server/Comment/Api/Interface/Spec.purs: -------------------------------------------------------------------------------- 1 | module Server.Comment.Api.Interface.Spec where 2 | 3 | import Payload.Spec (DELETE, GET, POST) 4 | import Payload.Spec (Routes) as Payload 5 | import Server.Comment.Api.Type.CreateDto (CreateDto) 6 | import Server.Comment.Api.Type.Misc (MultipleDto, SingleDto, Params) 7 | import Server.Shared.Api.Interface.Spec (AuthGuard, OptionalGuard, CorsGuard) 8 | import Server.Shared.Api.Type.Misc (ArticleParam) 9 | 10 | type Routes 11 | = Payload.Routes "/api/articles" 12 | { guards :: CorsGuard 13 | , create :: 14 | POST "//comments" 15 | { body :: CreateDto 16 | , params :: ArticleParam 17 | , guards :: AuthGuard 18 | , response :: SingleDto 19 | } 20 | , delete :: 21 | DELETE "//comments/" 22 | { guards :: AuthGuard 23 | , params :: Params 24 | } 25 | , get :: 26 | GET "//comments" 27 | { guards :: OptionalGuard 28 | , params :: ArticleParam 29 | , response :: MultipleDto 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /src/Server/Comment/Api/Main.purs: -------------------------------------------------------------------------------- 1 | module Server.Comment.Api.Main where 2 | 3 | import Prelude 4 | import Data.Bifunctor (bimap) 5 | import Data.Either (Either(..)) 6 | import Effect.Aff (Aff) 7 | import Payload.ResponseTypes (Empty(..), Response) 8 | import Payload.Server.Response (notFound, ok, unprocessableEntity) 9 | import Server.Comment.Api.Type.CreateDto (CreateDto, unwrapCreateDto) 10 | import Server.Comment.Api.Type.Misc (MultipleDto, Params, SingleDto, mkMultipleDto, mkSingleDto) 11 | import Server.Comment.Interface.Persistence (Handle) as Persistence 12 | import Server.Comment.Persistence.Postgres.Main as Postgres 13 | import Server.Comment.Type.Misc (InputError(..)) 14 | import Server.Shared.Api.Main (setHeaders, renderErrorEntity, renderErrorMessage) 15 | import Server.Shared.Api.Type.Misc (ArticleParam, AuthGuard, OptionalGuard, TResponse) 16 | import Server.Shared.Interface.Persistence (Handle) 17 | import Server.Shared.Type.Misc (Pool(..)) 18 | 19 | mkHandle :: Handle -> _ 20 | mkHandle h = 21 | { create: create h 22 | , delete: delete h 23 | , get: get h 24 | } 25 | 26 | next :: Handle -> Persistence.Handle 27 | next h = case h.pool of 28 | PostgresPool pool -> Postgres.mkHandle pool 29 | 30 | create :: Handle -> { body :: CreateDto, params :: ArticleParam, guards :: AuthGuard } -> Aff (TResponse SingleDto) 31 | create h { body: b, params: p, guards: g } = 32 | setHeaders g.origin 33 | <$> bimap renderError (ok <<< mkSingleDto) 34 | <$> (next h).insert g.userId (unwrapCreateDto b) p.slug 35 | 36 | get :: Handle -> { params :: ArticleParam, guards :: OptionalGuard } -> Aff (TResponse MultipleDto) 37 | get h { params: p, guards: g } = 38 | setHeaders g.origin 39 | <$> bimap renderError (ok <<< mkMultipleDto) 40 | <$> Right 41 | <$> (next h).search g.maybeUserId p.slug 42 | 43 | delete :: Handle -> { params :: Params, guards :: AuthGuard } -> Aff (TResponse Empty) 44 | delete h { params: p, guards: g } = 45 | setHeaders g.origin 46 | <$> bimap renderError (\_ -> ok Empty) 47 | <$> (next h).delete p.id p.slug 48 | 49 | renderError :: InputError -> Response String 50 | renderError NOT_FOUND = notFound $ renderErrorMessage "comment not found" 51 | renderError EMAIL_EXITS = unprocessableEntity $ renderErrorEntity "email" "exists" 52 | -------------------------------------------------------------------------------- /src/Server/Comment/Api/Type/CreateDto.purs: -------------------------------------------------------------------------------- 1 | module Server.Comment.Api.Type.CreateDto where 2 | 3 | import Prelude 4 | 5 | import Data.Bifunctor (lmap) 6 | import Data.Eq.Generic (genericEq) 7 | import Data.Generic.Rep (class Generic) 8 | import Data.Show.Generic (genericShow) 9 | import Foreign.Class (class Decode, class Encode) 10 | import Foreign.Generic (defaultOptions, genericDecode, genericEncode) 11 | import Payload.Server.DecodeBody (class DecodeBody) 12 | import Server.Comment.Type.Misc (Raw) 13 | import Server.Shared.Api.Main (renderJsonErrors) 14 | import Simple.JSON as SJ 15 | 16 | newtype CreateDto 17 | = CreateDto 18 | { comment :: Raw 19 | } 20 | 21 | derive instance genericCreateDto :: Generic CreateDto _ 22 | 23 | instance showCreateDto :: Show CreateDto where 24 | show = genericShow 25 | 26 | instance eqCreateDto :: Eq CreateDto where 27 | eq = genericEq 28 | 29 | instance decodeCreateDto :: Decode CreateDto where 30 | decode = genericDecode $ defaultOptions { unwrapSingleConstructors = true } 31 | 32 | instance encodeCreateDto :: Encode CreateDto where 33 | encode = genericEncode $ defaultOptions { unwrapSingleConstructors = true } 34 | 35 | derive newtype instance readForeignCreateDto :: SJ.ReadForeign CreateDto 36 | 37 | derive newtype instance writeForeignCreateDto :: SJ.WriteForeign CreateDto 38 | 39 | instance decodeBodyCreateDto :: SJ.ReadForeign CreateDto => DecodeBody CreateDto where 40 | decodeBody = lmap renderJsonErrors <<< SJ.readJSON 41 | 42 | wrapCreateDto :: Raw -> CreateDto 43 | wrapCreateDto x = CreateDto { comment: x } 44 | 45 | unwrapCreateDto :: CreateDto -> Raw 46 | unwrapCreateDto (CreateDto { comment: x }) = x 47 | -------------------------------------------------------------------------------- /src/Server/Comment/Api/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Comment.Api.Type.Misc where 2 | 3 | import Data.Either (Either) 4 | import Data.Nullable (Nullable, toNullable) 5 | import Payload.ResponseTypes (Failure) 6 | import Server.Comment.Type.Misc (Comment) 7 | import Shared.Type.Misc (Bio, Body, CommentId, CreatedAt, Following, Image, Slug, Username, UpdatedAt) 8 | 9 | type MultipleDto 10 | = { comments :: Array Comment 11 | } 12 | 13 | mkMultipleDto :: Array Comment -> MultipleDto 14 | mkMultipleDto comments = { comments } 15 | 16 | type MultipleResponse 17 | = Either Failure MultipleDto 18 | 19 | type SingleDto 20 | = { comment :: 21 | { author :: 22 | { bio :: Nullable Bio 23 | , following :: Following 24 | , image :: Nullable Image 25 | , username :: Username 26 | } 27 | , body :: Body 28 | , createdAt :: CreatedAt 29 | , id :: CommentId 30 | , updatedAt :: UpdatedAt 31 | } 32 | } 33 | 34 | mkSingleDto :: Comment -> SingleDto 35 | mkSingleDto i = 36 | { comment: 37 | { author: 38 | { bio: toNullable i.author.bio 39 | , image: toNullable i.author.image 40 | , username: i.author.username 41 | , following: i.author.following 42 | } 43 | , body: i.body 44 | , createdAt: i.createdAt 45 | , id: i.id 46 | , updatedAt: i.updatedAt 47 | } 48 | } 49 | 50 | type SingleResponse 51 | = Either Failure SingleDto 52 | 53 | type Params 54 | = { id :: CommentId 55 | , slug :: Slug 56 | } 57 | 58 | -------------------------------------------------------------------------------- /src/Server/Comment/Interface/Persistence.purs: -------------------------------------------------------------------------------- 1 | module Server.Comment.Interface.Persistence where 2 | 3 | import Data.Either (Either) 4 | import Data.Maybe (Maybe) 5 | import Effect.Aff (Aff) 6 | import Server.Comment.Type.Misc (Comment, InputError, Raw) 7 | import Shared.Type.Misc (CommentId, Slug, UserId) 8 | 9 | type Handle 10 | = { delete :: CommentId -> Slug -> Aff (Either InputError CommentId) 11 | , insert :: UserId -> Raw -> Slug -> Aff (Either InputError Comment) 12 | , search :: Maybe UserId -> Slug -> Aff (Array Comment) 13 | } 14 | -------------------------------------------------------------------------------- /src/Server/Comment/Persistence/Postgres/Main.purs: -------------------------------------------------------------------------------- 1 | module Server.Comment.Persistence.Postgres.Main where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Except (throwError) 6 | import Data.Either (Either(..), either) 7 | import Data.Maybe (Maybe(..), maybe) 8 | import Database.PostgreSQL (Pool) 9 | import Effect.Aff (Aff) 10 | import Effect.Exception (error) 11 | import Selda (Col, FullQuery, innerJoin, isNull, leftJoin, lit, not_, restrict, selectFrom, (.==)) 12 | import Selda.PG (litPG) 13 | import Selda.PG.Class (deleteFrom, insert1, query) 14 | import Selda.Query.Class (runSelda) 15 | import Server.Comment.Interface.Persistence (Handle) 16 | import Server.Comment.Persistence.Postgres.Type.Misc (DbOutputCols) 17 | import Server.Comment.Persistence.Postgres.Validation (validateSearch, validateInsert) 18 | import Server.Comment.Type.Misc (Comment, InputError, Raw) 19 | import Server.Shared.Persistence.Postgres.Main (withConnection) 20 | import Server.Shared.Persistence.Type.Misc (articleTable, commentTable, followingTable, userTable) 21 | import Server.Shared.Util.Selda (query1_) 22 | import Shared.Type.Misc (ArticleId, CommentId, Slug, UserId) 23 | 24 | mkHandle :: Pool -> Handle 25 | mkHandle p = 26 | { delete: delete p 27 | , insert: insert p 28 | , search: search p 29 | } 30 | 31 | search :: Pool -> Maybe UserId -> Slug -> Aff (Array Comment) 32 | search pool userId slug = 33 | withConnection pool 34 | (\conn -> runSelda conn $ query $ selectComment userId (Left slug)) 35 | >>= validateSearch 36 | 37 | selectComment :: forall s. Maybe UserId -> Either Slug CommentId -> FullQuery s (DbOutputCols s) 38 | selectComment userId slugOrId = 39 | selectFrom commentTable \c -> do 40 | a <- innerJoin articleTable \a -> a.id .== c.article_id 41 | u <- innerJoin userTable \u -> u.id .== c.author_id 42 | f <- 43 | leftJoin followingTable \f -> 44 | maybe (lit false) (\id -> f.followee_id .== u.id && f.follower_id .== litPG id) userId 45 | restrict $ either (\s -> a.slug .== (litPG s)) (\i -> c.id .== (litPG i)) slugOrId 46 | pure 47 | { bio: u.bio 48 | , following: not_ $ isNull f.follower_id 49 | , image: u.image 50 | , username: u.username 51 | , body: c.body 52 | , createdAt: c.created_at 53 | , id: c.id 54 | , updatedAt: c.updated_at 55 | } 56 | 57 | selectArticleId :: forall s. Slug -> FullQuery s ({ id :: Col s ArticleId }) 58 | selectArticleId slug = 59 | selectFrom articleTable \r -> do 60 | restrict $ r.slug .== (litPG slug) 61 | pure { id: r.id } 62 | 63 | insert :: Pool -> UserId -> Raw -> Slug -> Aff (Either InputError Comment) 64 | insert pool userId raw slug = 65 | withConnection pool 66 | ( \conn -> 67 | runSelda conn do 68 | { id: articleId } <- query1_ $ selectArticleId slug 69 | { id: commentId } <- insert1 commentTable { body: raw.body, article_id: articleId, author_id: userId } 70 | query1_ $ selectComment (Just userId) (Right commentId) 71 | ) 72 | >>= validateInsert 73 | 74 | delete :: Pool -> CommentId -> Slug -> Aff (Either InputError CommentId) 75 | delete pool id slug = 76 | withConnection pool 77 | ( \conn -> 78 | runSelda conn do 79 | deleteFrom commentTable (\r -> r.id .== (litPG id)) 80 | ) 81 | >>= either (throwError <<< error <<< show) (pure <<< Right <<< const id) 82 | -------------------------------------------------------------------------------- /src/Server/Comment/Persistence/Postgres/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Comment.Persistence.Postgres.Type.Misc where 2 | 3 | import Prelude 4 | import Data.DateTime.Instant (Instant, toDateTime) 5 | import Data.Maybe (Maybe) 6 | import Selda (Col) 7 | import Server.Comment.Type.Misc (Comment) 8 | import Shared.Type.Misc (Bio, Body, CommentId, Following, Identity, Image, Username) 9 | import Timestamp (Timestamp(..)) 10 | 11 | type Template col 12 | = ( bio :: col (Maybe Bio) 13 | , body :: col Body 14 | , createdAt :: col Instant 15 | , following :: col Following 16 | , id :: col CommentId 17 | , image :: col (Maybe Image) 18 | , updatedAt :: col Instant 19 | , username :: col Username 20 | ) 21 | 22 | type DbOutputCols s 23 | = { | Template (Col s) } 24 | 25 | type DbOutput 26 | = { | Template Identity } 27 | 28 | mkComment :: DbOutput -> Comment 29 | mkComment r = 30 | { author: 31 | { bio: r.bio 32 | , following: r.following 33 | , image: r.image 34 | , username: r.username 35 | } 36 | , body: r.body 37 | , createdAt: Timestamp $ toDateTime r.createdAt 38 | , id: r.id 39 | , updatedAt: Timestamp $ toDateTime r.updatedAt 40 | } 41 | -------------------------------------------------------------------------------- /src/Server/Comment/Persistence/Postgres/Validation.purs: -------------------------------------------------------------------------------- 1 | module Server.Comment.Persistence.Postgres.Validation where 2 | 3 | import Prelude 4 | import Control.Monad.Except (throwError) 5 | import Data.Either (Either(..)) 6 | import Database.PostgreSQL (PGError(..)) 7 | import Effect.Aff (Aff) 8 | import Effect.Exception (error) 9 | import Server.Comment.Persistence.Postgres.Type.Misc (DbOutput, mkComment) 10 | import Server.Comment.Type.Misc (Comment, InputError(..)) 11 | 12 | validateSearch :: Either PGError (Array DbOutput) -> Aff (Array Comment) 13 | validateSearch result = do 14 | case result of 15 | Left e -> throwError $ error $ show e 16 | Right rows -> pure $ mkComment <$> rows 17 | 18 | validateInsert :: Either PGError DbOutput -> Aff (Either InputError Comment) 19 | validateInsert result = do 20 | case result of 21 | Left e -> case e of 22 | IntegrityError detail -> case detail.constraint of 23 | "email_unique" -> pure $ Left EMAIL_EXITS 24 | otherwise -> throwError $ error $ show e 25 | -- | `query1_` Throws `ConversionError ∷ PGError` is case of no results. 26 | ConversionError _ -> pure $ Left NOT_FOUND 27 | otherwise -> throwError $ error $ show e 28 | Right a -> pure $ Right $ mkComment a 29 | -------------------------------------------------------------------------------- /src/Server/Comment/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Comment.Type.Misc where 2 | 3 | import Shared.Type.Misc (Author, Body, CommentId, CreatedAt, UpdatedAt) 4 | 5 | type Raw 6 | = { body :: Body 7 | } 8 | 9 | type Comment 10 | = { author :: Author 11 | , body :: Body 12 | , createdAt :: CreatedAt 13 | , id :: CommentId 14 | , updatedAt :: UpdatedAt 15 | } 16 | 17 | data InputError 18 | = NOT_FOUND 19 | | EMAIL_EXITS 20 | -------------------------------------------------------------------------------- /src/Server/Main.purs: -------------------------------------------------------------------------------- 1 | module Server.Main where 2 | 3 | import Prelude 4 | import Effect (Effect) 5 | import Effect.Aff (launchAff_) 6 | import Effect.Class (liftEffect) 7 | import Server.Shell.Main (runServer) 8 | import Server.Shell.Util.Config (readOrThrow) 9 | 10 | main :: Effect Unit 11 | main = 12 | launchAff_ do 13 | config <- readOrThrow "./config/Server/Dev.json" 14 | --config <- readOrThrow "./config/Server/Prod.json" 15 | liftEffect do runServer config 16 | -------------------------------------------------------------------------------- /src/Server/Profile/Api/Interface/Spec.purs: -------------------------------------------------------------------------------- 1 | module Server.Profile.Api.Interface.Spec where 2 | 3 | import Payload.Spec (DELETE, GET, POST, OPTIONS) 4 | import Payload.Spec (Routes) as Payload 5 | import Server.Profile.Api.Type.Misc (Dto) 6 | import Server.Shared.Api.Interface.Spec (AuthGuard, OptionalGuard, CorsGuard) 7 | import Server.Shared.Api.Type.Misc (UserParam, WildcardParam) 8 | 9 | type Routes 10 | = Payload.Routes "/api/profiles" 11 | { guards :: CorsGuard 12 | , byUsername :: 13 | Payload.Routes "/" 14 | { params :: UserParam 15 | , get :: 16 | GET "/" 17 | { guards :: OptionalGuard 18 | , response :: Dto 19 | } 20 | , follow :: 21 | POST "/follow" 22 | { guards :: AuthGuard 23 | , response :: Dto 24 | } 25 | , unfollow :: 26 | DELETE "/follow" 27 | { guards :: AuthGuard 28 | , response :: Dto 29 | } 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /src/Server/Profile/Api/Main.purs: -------------------------------------------------------------------------------- 1 | module Server.Profile.Api.Main where 2 | 3 | import Prelude 4 | import Data.Bifunctor (bimap) 5 | import Effect.Aff (Aff) 6 | import Payload.ResponseTypes (Response) 7 | import Payload.Server.Response (notFound, ok, unprocessableEntity) 8 | import Server.Profile.Api.Type.Misc (Dto, mkDto) 9 | import Server.Profile.Interface.Persistence (Handle) as Persistence 10 | import Server.Profile.Persistence.Postgres.Main as Postgres 11 | import Server.Profile.Type.Misc (InputError(..)) 12 | import Server.Shared.Api.Main (setHeaders, renderErrorMessage) 13 | import Server.Shared.Api.Type.Misc (AuthGuard, OptionalGuard, TResponse, UserParam) 14 | import Server.Shared.Interface.Persistence (Handle) 15 | import Server.Shared.Type.Misc (Pool(..)) 16 | 17 | mkHandle :: Handle -> _ 18 | mkHandle h = 19 | { byUsername: 20 | { follow: follow h 21 | , get: get h 22 | , unfollow: unfollow h 23 | } 24 | } 25 | 26 | -- 27 | next :: Handle -> Persistence.Handle 28 | next h = case h.pool of 29 | PostgresPool pool -> Postgres.mkHandle pool 30 | 31 | get :: Handle -> { guards :: OptionalGuard, params :: UserParam } -> Aff (TResponse Dto) 32 | get h { guards: g, params: p } = 33 | setHeaders g.origin 34 | <$> bimap renderError (ok <<< mkDto) 35 | <$> (next h).findFollowee g.maybeUserId p.username 36 | 37 | follow :: Handle -> { guards :: AuthGuard, params :: UserParam } -> Aff (TResponse Dto) 38 | follow h { guards: g, params: p } = 39 | setHeaders g.origin 40 | <$> bimap renderError (ok <<< mkDto) 41 | <$> (next h).insertFollower g.userId p.username 42 | 43 | unfollow :: Handle -> { guards :: AuthGuard, params :: UserParam } -> Aff (TResponse Dto) 44 | unfollow h { guards: g, params: p } = 45 | setHeaders g.origin 46 | <$> bimap renderError (ok <<< mkDto) 47 | <$> (next h).deleteFollower g.userId p.username 48 | 49 | renderError :: InputError -> Response String 50 | renderError NOT_FOUND = notFound $ renderErrorMessage "profile not found" 51 | renderError FOLLOWER_EQUALS_FOLLOWEE = unprocessableEntity $ renderErrorMessage "follower must be different from followee" 52 | renderError FOLLOWING_EXISTS = unprocessableEntity $ renderErrorMessage "already following" 53 | -------------------------------------------------------------------------------- /src/Server/Profile/Api/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Profile.Api.Type.Misc where 2 | 3 | import Data.Either (Either) 4 | import Data.Maybe (Maybe) 5 | import Data.Nullable (Nullable, toNullable) 6 | import Payload.ResponseTypes (Failure) 7 | import Server.Profile.Type.Misc (Profile) 8 | import Shared.Type.Misc (Bio, Image, Username, Following) 9 | 10 | type Dto 11 | = { profile :: 12 | { bio :: Nullable Bio 13 | , image :: Nullable Image 14 | , username :: Username 15 | , following :: Following 16 | } 17 | } 18 | 19 | mkDto :: Profile -> Dto 20 | mkDto i = 21 | { profile: 22 | { bio: toNullable i.bio 23 | , image: toNullable i.image 24 | , username: i.username 25 | , following: i.following 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /src/Server/Profile/Interface/Persistence.purs: -------------------------------------------------------------------------------- 1 | module Server.Profile.Interface.Persistence where 2 | 3 | import Data.Either (Either) 4 | import Data.Maybe (Maybe) 5 | import Effect.Aff (Aff) 6 | import Server.Profile.Type.Misc (InputError, Profile) 7 | import Shared.Type.Misc (FolloweeUsername, FollowerId) 8 | 9 | type Handle 10 | = { findFollowee :: Maybe FollowerId -> FolloweeUsername -> Aff (Either InputError Profile) 11 | , insertFollower :: FollowerId -> FolloweeUsername -> Aff (Either InputError Profile) 12 | , deleteFollower :: FollowerId -> FolloweeUsername -> Aff (Either InputError Profile) 13 | } 14 | -------------------------------------------------------------------------------- /src/Server/Profile/Persistence/Postgres/Main.purs: -------------------------------------------------------------------------------- 1 | -- | Reminder: All functions are supposed to do what they say otherwise it is an input error or an 2 | -- | other kind of error. Input errors are returned, others are thrown. 3 | module Server.Profile.Persistence.Postgres.Main where 4 | 5 | import Prelude 6 | 7 | import Data.Either (Either) 8 | import Data.Maybe (Maybe(..), maybe) 9 | import Database.PostgreSQL (Pool) 10 | import Effect.Aff (Aff) 11 | import Selda (Col, FullQuery, isNull, leftJoin, lit, not_, restrict, selectFrom, (.==)) 12 | import Selda.PG (litPG) 13 | import Selda.PG.Class (deleteFrom, insert1_) 14 | import Selda.Query.Class (runSelda) 15 | import Server.Profile.Interface.Persistence (Handle) 16 | import Server.Profile.Persistence.Postgres.Type.Misc (DbOutputCols) 17 | import Server.Profile.Persistence.Postgres.Validation (validateSingle) 18 | import Server.Profile.Type.Misc (InputError, Profile) 19 | import Server.Shared.Persistence.Postgres.Main (withConnection) 20 | import Server.Shared.Persistence.Type.Misc (followingTable, userTable) 21 | import Server.Shared.Util.Selda (query1_) 22 | import Shared.Type.Misc (FolloweeUsername, FollowerId, Username, UserId) 23 | 24 | mkHandle :: Pool -> Handle 25 | mkHandle p = 26 | { deleteFollower: deleteFollower p 27 | , findFollowee: findFollowee p 28 | , insertFollower: insertFollower p 29 | } 30 | 31 | findFollowee :: Pool -> Maybe FollowerId -> FolloweeUsername -> Aff (Either InputError Profile) 32 | findFollowee pool followerId followeeUsername = 33 | withConnection pool 34 | (\conn -> runSelda conn $ query1_ $ selectFollowee followerId followeeUsername) 35 | >>= validateSingle 36 | 37 | selectFollowee :: forall s. Maybe FollowerId -> FolloweeUsername -> FullQuery s (DbOutputCols s) 38 | selectFollowee followerId followeeUsername = 39 | selectFrom userTable \fee -> do 40 | following <- 41 | leftJoin followingTable \f -> 42 | maybe (lit false) (\id -> f.followee_id .== fee.id && f.follower_id .== litPG id) followerId 43 | restrict $ fee.username .== (litPG followeeUsername) 44 | pure 45 | { bio: fee.bio 46 | , following: not_ $ isNull following.follower_id 47 | , image: fee.image 48 | , username: fee.username 49 | } 50 | 51 | selectUserId :: forall s. Username -> FullQuery s ({ id :: Col s UserId }) 52 | selectUserId username = 53 | selectFrom userTable \r -> do 54 | restrict $ r.username .== (litPG username) 55 | pure { id: r.id } 56 | 57 | insertFollower :: Pool -> FollowerId -> FolloweeUsername -> Aff (Either InputError Profile) 58 | insertFollower pool followerId followeeUsername = 59 | withConnection pool 60 | ( \conn -> 61 | runSelda conn do 62 | { id: followeeId } <- query1_ $ selectUserId followeeUsername 63 | insert1_ followingTable { follower_id: followerId, followee_id: followeeId } 64 | query1_ $ selectFollowee (Just followerId) followeeUsername 65 | ) 66 | >>= validateSingle 67 | 68 | deleteFollower :: Pool -> FollowerId -> FolloweeUsername -> Aff (Either InputError Profile) 69 | deleteFollower pool followerId followeeUsername = 70 | withConnection pool 71 | ( \conn -> 72 | runSelda conn do 73 | { id: followeeId } <- query1_ $ selectUserId followeeUsername 74 | deleteFrom followingTable (\r -> r.follower_id .== litPG followerId && r.followee_id .== litPG followeeId) 75 | query1_ $ selectFollowee (Just followerId) followeeUsername 76 | ) 77 | >>= validateSingle 78 | -------------------------------------------------------------------------------- /src/Server/Profile/Persistence/Postgres/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Profile.Persistence.Postgres.Type.Misc where 2 | 3 | import Selda (Col) 4 | import Server.Profile.Type.Misc (Template) 5 | 6 | type DbOutputCols s 7 | = { | Template (Col s) } 8 | -------------------------------------------------------------------------------- /src/Server/Profile/Persistence/Postgres/Validation.purs: -------------------------------------------------------------------------------- 1 | module Server.Profile.Persistence.Postgres.Validation where 2 | 3 | import Prelude 4 | import Control.Monad.Except (throwError) 5 | import Data.Either (Either(..)) 6 | import Database.PostgreSQL (PGError(..)) 7 | import Effect.Aff (Aff) 8 | import Effect.Exception (error) 9 | import Server.Profile.Type.Misc (InputError(..)) 10 | 11 | validateSingle :: forall a. Either PGError a -> Aff (Either InputError a) 12 | validateSingle result = do 13 | case result of 14 | Left e -> case e of 15 | IntegrityError detail -> case detail.constraint of 16 | "follower_not_followee" -> pure $ Left FOLLOWER_EQUALS_FOLLOWEE 17 | "following_unique" -> pure $ Left FOLLOWING_EXISTS 18 | otherwise -> throwError $ error $ show e 19 | -- | `query1_` Throws `ConversionError ∷ PGError` is case of no results. 20 | ConversionError _ -> pure $ Left NOT_FOUND 21 | otherwise -> throwError $ error $ show e 22 | Right a -> pure $ Right a 23 | -------------------------------------------------------------------------------- /src/Server/Profile/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Profile.Type.Misc where 2 | 3 | import Data.Maybe (Maybe) 4 | import Shared.Type.Misc (Bio, Image, Username, Identity) 5 | 6 | type Template col 7 | = ( bio :: col (Maybe Bio) 8 | , following :: col Boolean 9 | , image :: col (Maybe Image) 10 | , username :: col Username 11 | ) 12 | 13 | type Profile 14 | = { | Template Identity } 15 | 16 | data InputError 17 | = NOT_FOUND 18 | | FOLLOWER_EQUALS_FOLLOWEE 19 | | FOLLOWING_EXISTS 20 | -------------------------------------------------------------------------------- /src/Server/Shared/Api/Headers.purs: -------------------------------------------------------------------------------- 1 | module Server.Shared.Api.Headers where 2 | 3 | import Data.Tuple (Tuple(..)) 4 | import Payload.Headers as P 5 | import Server.Shared.Api.Type.Misc (Origin) 6 | 7 | baseHeaders :: Origin -> P.Headers 8 | baseHeaders origin = 9 | P.fromFoldable 10 | [ Tuple "Access-Control-Allow-Origin" origin 11 | , Tuple "Access-Control-Allow-Methods" "GET, OPTIONS, POST, PUT, DELETE" 12 | , Tuple "Access-Control-Allow-Headers" "Content-Type,Authorization,X-Requested-With" 13 | ] 14 | -------------------------------------------------------------------------------- /src/Server/Shared/Api/Interface/Spec.purs: -------------------------------------------------------------------------------- 1 | module Server.Shared.Api.Interface.Spec where 2 | 3 | import Payload.Spec (type (:), Guards, Nil) 4 | 5 | type AuthGuard 6 | = Guards ("userId" : Nil) 7 | 8 | type OptionalGuard 9 | = Guards ("maybeUserId" : Nil) 10 | 11 | type CorsGuard 12 | = Guards ("origin" : Nil) 13 | -------------------------------------------------------------------------------- /src/Server/Shared/Api/Main.purs: -------------------------------------------------------------------------------- 1 | module Server.Shared.Api.Main where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either(..)) 6 | import Data.Foldable as Fold 7 | import Data.List.NonEmpty (NonEmptyList) 8 | import Effect.Aff (Aff) 9 | import Foreign (ForeignError(..)) 10 | import Payload.ContentType (json, plain) 11 | import Payload.Headers (set) 12 | import Payload.ResponseTypes (Empty(..), Response) as P 13 | import Payload.Server.Response (noContent, setHeaders) as P 14 | import PointFree ((<..)) 15 | import Server.Shared.Api.Headers (baseHeaders) 16 | import Server.Shared.Api.Type.Misc (CorsGuard, Origin, TResponse, WildcardParam) 17 | import Shared.Util.String (format1, format2) 18 | 19 | renderBody :: String -> String 20 | renderBody = format1 "{\n\t\"errors\":{\n{1}\n\t}\n}" 21 | 22 | renderEntry :: String -> String -> String 23 | renderEntry = format2 "\t\t\"{1}\": [\"{2}\"]" 24 | 25 | renderMessage :: String -> String 26 | renderMessage = renderEntry "message" 27 | 28 | defaultForeignError :: String 29 | defaultForeignError = "json format invalid" 30 | 31 | renderDefaultMessage :: String 32 | renderDefaultMessage = renderMessage defaultForeignError 33 | 34 | intercalate :: forall a. Fold.Foldable a => a String -> String 35 | intercalate = Fold.intercalate ", \n" 36 | 37 | renderJsonErrors :: NonEmptyList ForeignError -> String 38 | renderJsonErrors e = renderBody $ intercalate $ renderForeignError <$> e 39 | 40 | renderForeignError :: ForeignError -> String 41 | renderForeignError (ForeignError msg) = renderMessage msg 42 | renderForeignError (ErrorAtIndex i e) = renderDefaultMessage 43 | renderForeignError (TypeMismatch exp act) = renderDefaultMessage 44 | renderForeignError (ErrorAtProperty prop e) = renderForeignError' e 45 | 46 | renderForeignError' :: ForeignError -> String 47 | renderForeignError' (ForeignError msg) = renderMessage msg 48 | renderForeignError' (ErrorAtIndex i e) = renderDefaultMessage 49 | renderForeignError' (TypeMismatch exp act) = renderDefaultMessage 50 | renderForeignError' (ErrorAtProperty prop e) = renderEntry prop $ renderForeignError'' e 51 | 52 | renderForeignError'' :: ForeignError -> String 53 | renderForeignError'' (ForeignError msg) = msg 54 | renderForeignError'' (ErrorAtIndex i e) = defaultForeignError 55 | renderForeignError'' (TypeMismatch _ "Undefined") = "missing" 56 | renderForeignError'' (TypeMismatch exp act) = "Type mismatch: expected " <> exp <> ", found " <> act 57 | renderForeignError'' (ErrorAtProperty prop e) = defaultForeignError 58 | 59 | setHeaders :: forall a. Origin -> Either (P.Response String) (P.Response a) -> TResponse a 60 | setHeaders origin appResult = case appResult of 61 | Left e -> Left $ P.setHeaders headers $ e 62 | Right a -> Right $ P.setHeaders headers $ a 63 | where 64 | headers = 65 | set "Content-Type" json 66 | $ baseHeaders origin 67 | 68 | options :: { guards :: CorsGuard, params :: WildcardParam } -> Aff (TResponse P.Empty) 69 | options { guards: g, params: _ } = pure $ Right $ P.setHeaders headers $ P.noContent P.Empty 70 | where 71 | headers = 72 | set "Content-Type" plain 73 | $ set "Content-Length" "0" 74 | $ baseHeaders g.origin 75 | 76 | renderErrorEntity :: String -> String -> String 77 | renderErrorEntity = renderBody <.. renderEntry 78 | 79 | renderErrorMessage :: String -> String 80 | renderErrorMessage = renderErrorEntity "message" 81 | -------------------------------------------------------------------------------- /src/Server/Shared/Api/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Shared.Api.Type.Misc where 2 | 3 | import Data.Either (Either) 4 | import Data.List (List) 5 | import Data.Maybe (Maybe) 6 | import Payload.ResponseTypes (Failure, Response) as P 7 | import Shared.Type.Misc (Slug, UserId, Username) 8 | import Shared.Type.ShortString (ShortString) 9 | 10 | type AuthGuard 11 | = { userId :: UserId, origin :: String } 12 | 13 | type OptionalGuard 14 | = { maybeUserId :: Maybe UserId, origin :: String } 15 | 16 | type CorsGuard 17 | = { origin :: String } 18 | 19 | type Guards 20 | = { userId :: UserId, maybeUserId :: Maybe UserId, origin :: Origin } 21 | 22 | type UserParam 23 | = { username :: Username } 24 | 25 | type ArticleParam 26 | = { slug :: Slug } 27 | 28 | type WildcardParam 29 | = { wildcard :: List String } 30 | 31 | type Origin 32 | = String 33 | 34 | type TResponse a 35 | = Either (P.Response String) (P.Response a) 36 | -------------------------------------------------------------------------------- /src/Server/Shared/Interface/Aggregate.purs: -------------------------------------------------------------------------------- 1 | module Server.Shared.Interface.Aggregate where 2 | 3 | import Server.Shared.Interface.Persistence as Persistence 4 | import Server.Shared.Interface.Token as Token 5 | 6 | type Handle 7 | = { persistence :: Persistence.Handle 8 | , token :: Token.Handle 9 | } 10 | 11 | -------------------------------------------------------------------------------- /src/Server/Shared/Interface/Persistence.purs: -------------------------------------------------------------------------------- 1 | module Server.Shared.Interface.Persistence where 2 | 3 | import Server.Shared.Type.Misc (Pool) 4 | 5 | type Handle 6 | = { pool :: Pool } 7 | 8 | -------------------------------------------------------------------------------- /src/Server/Shared/Interface/Token.purs: -------------------------------------------------------------------------------- 1 | module Server.Shared.Interface.Token where 2 | 3 | import Data.Maybe (Maybe) 4 | import Effect.Aff (Aff) 5 | import Shared.Type.Misc (UserId, Token) 6 | 7 | type Handle 8 | = { encode :: UserId -> Aff Token 9 | , decode :: Token -> Aff (Maybe UserId) 10 | } 11 | 12 | -------------------------------------------------------------------------------- /src/Server/Shared/Persistence/Main.purs: -------------------------------------------------------------------------------- 1 | module Server.Shared.Persistence.Postgres.Main where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (throwError) 6 | import Data.Either (Either(..)) 7 | import Database.PostgreSQL as PG 8 | import Effect.Aff (Aff, error) 9 | import Effect.Class (class MonadEffect) 10 | import Effect.Class.Console (log) 11 | import Selda (Col(..), FullQuery, Table, showQuery, showUpdate) 12 | import Selda.Col (class GetCols, showCol) 13 | import Selda.Expr (Expr(..)) 14 | import Selda.PG (litPG, showPG) 15 | import Selda.Query.PrettyPrint (dodoPrint) 16 | import Selda.Query.ShowStatement (ppQuery) 17 | import Selda.Query.Utils (class TableToColsWithoutAlias) 18 | import Simple.JSON as JSON 19 | 20 | withConnection :: forall a. PG.Pool -> (PG.Connection -> Aff a) -> Aff a 21 | withConnection pool f = 22 | PG.withConnection pool case _ of 23 | Left pgError -> throwError $ error $ ("PostgreSQL connection error: " <> show pgError) 24 | Right conn -> f conn 25 | 26 | crypt :: forall s a. Col s a -> Col s a -> Col s a 27 | crypt value passwordHashCol = 28 | Col 29 | $ Any do 30 | s <- showCol passwordHashCol 31 | v <- showCol value 32 | pure $ "crypt(" <> v <> ", " <> s <> ")" 33 | 34 | cryptGenSalt :: forall s a. Col s a -> Col s a 35 | cryptGenSalt value = 36 | Col 37 | $ Any do 38 | v <- showCol value 39 | bf <- showCol $ litPG "bf" 40 | pure $ "crypt(" <> v <> ", gen_salt(" <> bf <> "))" 41 | 42 | toTextArray :: forall s a. Col s a -> Col s a 43 | toTextArray col = 44 | Col 45 | $ Any do 46 | v <- showCol col 47 | pure $ v <> "::TEXT[]" 48 | 49 | toArrayTextArray :: forall a i s. GetCols i => FullQuery s (Record i) → Col s a 50 | toArrayTextArray q = 51 | Col 52 | $ Any do 53 | s <- dodoPrint <$> ppQuery q 54 | pure $ "ARRAY (" <> s <> ")::TEXT[]" 55 | 56 | unnest :: forall s a. Col s a -> Col s a 57 | unnest col = 58 | Col 59 | $ Any do 60 | v <- showCol col 61 | pure $ "UNNEST (" <> v <> ")" 62 | 63 | subQuery :: forall a s. FullQuery s { value :: Col s a } → Col s a 64 | subQuery q = 65 | Col 66 | $ Any do 67 | s <- dodoPrint <$> ppQuery q 68 | pure $ "(" <> s <> ")" 69 | 70 | any :: forall a s. Col s (Array a) -> Col s a 71 | any col = 72 | Col 73 | $ Any do 74 | s <- showCol col 75 | pure $ "ANY (" <> s <> ")" 76 | 77 | logQuery :: forall s i m. GetCols i => MonadEffect m => FullQuery s { | i } -> m Unit 78 | logQuery q = do 79 | let 80 | { strQuery, params } = showPG $ showQuery q 81 | log strQuery 82 | log $ JSON.unsafeStringify params 83 | log "" 84 | 85 | logUpdate ∷ 86 | forall t s r m. 87 | TableToColsWithoutAlias s t r => 88 | GetCols r => 89 | MonadEffect m => 90 | Table t → ({ | r } → Col s Boolean) → ({ | r } → { | r }) → m Unit 91 | logUpdate table pred up = do 92 | let 93 | { strQuery, params } = showPG $ showUpdate table pred up 94 | log strQuery 95 | log $ JSON.unsafeStringify params 96 | log "" 97 | -------------------------------------------------------------------------------- /src/Server/Shared/Persistence/Postgres/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Shared.Persistence.Type.Misc where 2 | 3 | import Prelude 4 | import Data.DateTime.Instant (Instant) 5 | import Data.Maybe (Maybe(..)) 6 | import Selda (Table(..)) 7 | import Selda.PG (generateSeries) 8 | import Selda.Table.Constraint (Auto, Default) 9 | import Shared.Type.Misc (ArticleId, Bio, Body, CommentId, CreatedAt, Description, Email, Image, Password, Slug, Tag, Title, UserId, Username, UpdatedAt) 10 | 11 | type UserTable 12 | = Table 13 | ( bio :: Maybe Bio 14 | , email :: Email 15 | , id :: Auto UserId 16 | , image :: Maybe Image 17 | , password :: Password 18 | , username :: Username 19 | ) 20 | 21 | userTable :: UserTable 22 | userTable = 23 | Source "user" 24 | $ case _ of 25 | Nothing -> "\"user\"" 26 | Just alias -> "\"user\"" <> " " <> alias 27 | 28 | type FollowingTable 29 | = Table ( follower_id :: UserId, followee_id :: UserId ) 30 | 31 | followingTable :: FollowingTable 32 | followingTable = Table { name: "following" } 33 | 34 | type CommentTable 35 | = Table 36 | ( article_id :: ArticleId 37 | , author_id :: UserId 38 | , body :: Body 39 | , created_at :: Auto Instant 40 | , id :: Auto CommentId 41 | , updated_at :: Auto Instant 42 | ) 43 | 44 | commentTable :: CommentTable 45 | commentTable = Table { name: "comment" } 46 | 47 | type ArticleTable 48 | = Table 49 | ( author_id :: UserId 50 | , body :: Body 51 | , created_at :: Auto Instant 52 | , description :: Description 53 | , id :: Auto ArticleId 54 | , slug :: Slug 55 | , tag_list :: Array Tag 56 | , title :: Title 57 | , updated_at :: Auto Instant 58 | ) 59 | 60 | articleTable :: ArticleTable 61 | articleTable = Table { name: "article" } 62 | 63 | type FavoritedTable 64 | = Table 65 | ( user_id :: UserId 66 | , article_id :: ArticleId 67 | ) 68 | 69 | favoritedTable :: FavoritedTable 70 | favoritedTable = Table { name: "favorited" } 71 | 72 | unitTable :: Table ( i :: Int ) 73 | unitTable = generateSeries 1 1 74 | -------------------------------------------------------------------------------- /src/Server/Shared/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Shared.Type.Misc where 2 | 3 | import Database.PostgreSQL (Pool) as PG 4 | 5 | data Pool 6 | = PostgresPool PG.Pool 7 | -------------------------------------------------------------------------------- /src/Server/Shared/Util/Json.purs: -------------------------------------------------------------------------------- 1 | -- | Copied from https://github.com/justinwoo/purescript-simple-json/blob/master/test/EnumSumGeneric.purs 2 | module Server.Shared.Util.Json where 3 | 4 | import Prelude 5 | import Control.Alt ((<|>)) 6 | import Control.Monad.Except (throwError) 7 | import Data.Generic.Rep (class Generic, Constructor(..), NoArguments(..), Sum(..), to) 8 | import Foreign (Foreign) 9 | import Foreign as Foreign 10 | import Simple.JSON as JSON 11 | import Type.Prelude (class IsSymbol, SProxy(..), reflectSymbol) 12 | 13 | enumReadForeign :: 14 | forall a rep. 15 | Generic a rep => 16 | EnumReadForeign rep => 17 | Foreign -> 18 | Foreign.F a 19 | enumReadForeign f = to <$> enumReadForeignImpl f 20 | 21 | -- type class for "enums", or nullary sum types 22 | class EnumReadForeign rep where 23 | enumReadForeignImpl :: Foreign -> Foreign.F rep 24 | 25 | instance sumEnumReadForeign :: 26 | ( EnumReadForeign a 27 | , EnumReadForeign b 28 | ) => 29 | EnumReadForeign (Sum a b) where 30 | enumReadForeignImpl f = 31 | Inl <$> enumReadForeignImpl f 32 | <|> Inr 33 | <$> enumReadForeignImpl f 34 | 35 | instance constructorEnumReadForeign :: 36 | ( IsSymbol name 37 | ) => 38 | EnumReadForeign (Constructor name NoArguments) where 39 | enumReadForeignImpl f = do 40 | s <- JSON.readImpl f 41 | if s == name then 42 | pure $ Constructor NoArguments 43 | else 44 | throwError <<< pure <<< Foreign.ForeignError 45 | $ "Enum string " 46 | <> s 47 | <> " did not match expected string " 48 | <> name 49 | where 50 | name = reflectSymbol (SProxy :: SProxy name) 51 | -------------------------------------------------------------------------------- /src/Server/Shared/Util/Selda.purs: -------------------------------------------------------------------------------- 1 | module Server.Shared.Util.Selda where 2 | 3 | import Prelude 4 | import Control.Monad.Error.Class (throwError) 5 | import Data.Maybe (maybe) 6 | import Database.PostgreSQL (PGError(..)) 7 | import Selda.PG.Class (BackendPGClass, class MonadSeldaPG, query1) 8 | import Selda.Query.Class (class GenericQuery) 9 | import Selda.Query.Type (FullQuery) 10 | 11 | type B 12 | = BackendPGClass 13 | 14 | -- | Throws `ConversionError ∷ PGError` is case of no results. 15 | query1_ ∷ 16 | ∀ o i m. 17 | GenericQuery BackendPGClass m i o ⇒ 18 | MonadSeldaPG m ⇒ 19 | FullQuery B { | i } → m { | o } 20 | query1_ = query1 >=> maybe (throwError err) pure 21 | where 22 | err = ConversionError "Cannot execute `query1_`: result array is empty" 23 | -------------------------------------------------------------------------------- /src/Server/Shell/Api/Guards.purs: -------------------------------------------------------------------------------- 1 | module Server.Shell.Api.Guards where 2 | 3 | import Prelude 4 | import Control.Error.Util (note) 5 | import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT) 6 | import Data.Either (Either(..)) 7 | import Data.Maybe (Maybe(..)) 8 | import Data.String (Pattern(..), Replacement(..), replace) 9 | import Effect.Aff (Aff) 10 | import Node.HTTP (Request) 11 | import Payload.Headers as Headers 12 | import Payload.ResponseTypes (Response) 13 | import Payload.Server.Guards as Payload 14 | import Payload.Server.Response (unauthorized) 15 | import Server.Shared.Api.Main (renderErrorMessage) 16 | import Server.Shared.Api.Type.Misc (Origin) 17 | import Server.Shared.Interface.Token (Handle) 18 | import Shared.Type.Misc (UserId) 19 | 20 | mkHandle :: 21 | Handle -> 22 | { maybeUserId :: Request -> Aff (Either (Response String) (Maybe UserId)) 23 | , userId :: Request -> Aff (Either (Response String) UserId) 24 | , origin :: Request -> Aff (Either (Response String) Origin) 25 | } 26 | mkHandle h = 27 | { userId: authUser h 28 | , maybeUserId: maybeAuthUser h 29 | , origin: authOrigin 30 | } 31 | 32 | maybeAuthUser :: Handle -> Request -> Aff (Either (Response String) (Maybe UserId)) 33 | maybeAuthUser h req = 34 | authUser h req 35 | >>= case _ of 36 | Left _ -> pure $ Right Nothing 37 | Right u -> pure $ Right $ Just u 38 | 39 | authUser :: Handle -> Request -> Aff (Either (Response String) UserId) 40 | authUser h req = 41 | runMaybeT do 42 | str <- MaybeT $ Headers.lookup "authorization" <$> Payload.headers req 43 | inter <- MaybeT $ pure $ Just $ replace (Pattern "Bearer ") (Replacement "") str 44 | token <- MaybeT $ pure $ Just $ replace (Pattern "Token ") (Replacement "") inter 45 | id <- MaybeT $ h.decode token 46 | pure id 47 | <#> note (unauthorized $ renderErrorMessage "Invalid token") 48 | 49 | authOrigin :: Request -> Aff (Either (Response String) Origin) 50 | authOrigin req = 51 | (Headers.lookup "origin" <$> Payload.headers req) 52 | <#> note (unauthorized $ renderErrorMessage "Origin missing") 53 | -------------------------------------------------------------------------------- /src/Server/Shell/Api/Interface/Spec.purs: -------------------------------------------------------------------------------- 1 | module Server.Shell.Api.Interface.Spec where 2 | 3 | import Payload.Spec (OPTIONS) 4 | import Payload.Spec as Payload 5 | import Server.Article.Api.Interface.Spec (Routes) as Article 6 | import Server.Comment.Api.Interface.Spec (Routes) as Comment 7 | import Server.Profile.Api.Interface.Spec (Routes) as Profile 8 | import Server.Shared.Api.Interface.Spec (CorsGuard) 9 | import Server.Shared.Api.Type.Misc (Guards, WildcardParam) 10 | import Server.User.Api.Interface.Spec (Routes) as User 11 | 12 | type Spec 13 | = { guards :: Guards 14 | , routes :: 15 | { article :: Article.Routes 16 | , comment :: Comment.Routes 17 | , profile :: Profile.Routes 18 | , shared :: CorsRoutes 19 | , user :: User.Routes 20 | } 21 | } 22 | 23 | -- 24 | type CorsRoutes 25 | = Payload.Routes "/api" 26 | { guards :: CorsGuard 27 | , options :: OPTIONS "/<..wildcard>" { params :: WildcardParam } 28 | } 29 | 30 | spec :: Payload.Spec Spec 31 | spec = Payload.Spec 32 | -------------------------------------------------------------------------------- /src/Server/Shell/Api/Main.purs: -------------------------------------------------------------------------------- 1 | module Server.Shell.Api.Main where 2 | 3 | import Server.Article.Api.Main (mkHandle) as Article 4 | import Server.Comment.Api.Main (mkHandle) as Comment 5 | import Server.Profile.Api.Main (mkHandle) as Profile 6 | import Server.Shared.Api.Main (options) 7 | import Server.Shared.Interface.Aggregate (Handle) 8 | import Server.Shell.Api.Guards (mkHandle) as Guard 9 | import Server.User.Api.Main (mkHandle) as User 10 | 11 | mkHandle :: Handle -> _ 12 | mkHandle h = 13 | { handlers: 14 | { article: Article.mkHandle h.persistence 15 | , comment: Comment.mkHandle h.persistence 16 | , profile: Profile.mkHandle h.persistence 17 | , shared: { options: options } 18 | , user: User.mkHandle h 19 | } 20 | , guards: Guard.mkHandle h.token 21 | } 22 | 23 | --, --, 24 | -------------------------------------------------------------------------------- /src/Server/Shell/Main.purs: -------------------------------------------------------------------------------- 1 | module Server.Shell.Main where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either(..)) 6 | import Data.Maybe (Maybe(..)) 7 | import Effect (Effect) 8 | import Effect.Aff (launchAff_) 9 | import Effect.Class.Console (log) 10 | import Payload.Server as Payload 11 | import Server.Shell.Api.Interface.Spec (spec) as Api 12 | import Server.Shell.Api.Main (mkHandle) as Api 13 | import Server.Shell.Type.LogLevel as Log 14 | import Server.Shell.Type.Misc (Config) 15 | import Server.Shell.Util.Aggregate (mkHandle) as Aggregate 16 | 17 | mkServerOpts :: Config -> Payload.Options 18 | mkServerOpts config = 19 | { backlog: Nothing 20 | , hostname: config.server.hostname 21 | , port: config.server.port 22 | , logLevel: ll config.server.logLevel 23 | } 24 | where 25 | ll :: Log.LogLevel -> Payload.LogLevel 26 | ll Log.Debug = Payload.LogDebug 27 | ll Log.Silent = Payload.LogSilent 28 | ll Log.Error = Payload.LogError 29 | ll Log.Normal = Payload.LogNormal 30 | 31 | runServer :: Config -> Effect Unit 32 | runServer c = do 33 | let 34 | serverOpts = mkServerOpts c 35 | h <- Aggregate.mkHandle c 36 | launchAff_ do 37 | result <- Payload.startGuarded serverOpts Api.spec $ Api.mkHandle h 38 | case result of 39 | Left e -> log e 40 | Right _ -> pure unit 41 | -------------------------------------------------------------------------------- /src/Server/Shell/Persistence/Postgres/Main.purs: -------------------------------------------------------------------------------- 1 | module Server.Shell.Persistence.Postgres.Main where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe(..)) 6 | import Database.PostgreSQL as PG 7 | import Effect (Effect) 8 | import Server.Shared.Interface.Persistence (Handle) 9 | import Server.Shared.Type.Misc (Pool(..)) 10 | import Server.Shell.Type.Misc (PersistenceConfig) 11 | 12 | mkHandle :: PersistenceConfig -> Effect Handle 13 | mkHandle config = do 14 | pool <- createPool config 15 | pure { pool: PostgresPool pool } 16 | 17 | createPool :: PersistenceConfig -> Effect PG.Pool 18 | createPool c = PG.new pgConfig 19 | where 20 | pgConfig = 21 | (PG.defaultConfiguration c.database) 22 | { host = Just c.hostname 23 | , user = Just c.user 24 | , port = Just 5432 25 | , password = Just c.password 26 | } 27 | -------------------------------------------------------------------------------- /src/Server/Shell/Type/DebugLevel.purs: -------------------------------------------------------------------------------- 1 | module Server.Shell.Type.LogLevel where 2 | 3 | import Prelude 4 | 5 | import Data.Generic.Rep (class Generic) 6 | import Data.Show.Generic (genericShow) 7 | import Server.Shared.Util.Json (enumReadForeign) 8 | import Simple.JSON as JSON 9 | 10 | data LogLevel 11 | = Debug 12 | | Silent 13 | | Error 14 | | Normal 15 | 16 | derive instance genericLogLevel :: Generic LogLevel _ 17 | 18 | instance logLevelReadForeign :: JSON.ReadForeign LogLevel where 19 | readImpl = enumReadForeign 20 | 21 | instance logLevelShow :: Show LogLevel where 22 | show = genericShow 23 | -------------------------------------------------------------------------------- /src/Server/Shell/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.Shell.Type.Misc where 2 | 3 | import Data.Maybe (Maybe) 4 | import Server.Shell.Type.LogLevel (LogLevel) 5 | import Server.Shell.Type.PersistenceImpl (PersistenceImpl) 6 | import Timestamp (Timestamp) 7 | 8 | type ServerConfig 9 | = { port :: Int 10 | , hostname :: String 11 | , logLevel :: LogLevel 12 | } 13 | 14 | type PersistenceConfig 15 | = { hostname :: String 16 | , database :: String 17 | , user :: String 18 | , password :: String 19 | , impl :: PersistenceImpl 20 | } 21 | 22 | type TokenConfig 23 | = { timestamp :: Maybe Timestamp 24 | , secret :: String 25 | } 26 | 27 | type Config 28 | = { server :: ServerConfig 29 | , persistence :: PersistenceConfig 30 | , token :: TokenConfig 31 | } 32 | -------------------------------------------------------------------------------- /src/Server/Shell/Type/PersistenceImpl.purs: -------------------------------------------------------------------------------- 1 | module Server.Shell.Type.PersistenceImpl where 2 | 3 | import Prelude 4 | 5 | import Data.Generic.Rep (class Generic) 6 | import Data.Show.Generic (genericShow) 7 | import Server.Shared.Util.Json (enumReadForeign) 8 | import Simple.JSON as JSON 9 | 10 | data PersistenceImpl 11 | = Postgres 12 | 13 | derive instance genericPersistenceImpl :: Generic PersistenceImpl _ 14 | 15 | instance persistenceImplReadForeign :: JSON.ReadForeign PersistenceImpl where 16 | readImpl = enumReadForeign 17 | 18 | instance persistenceImplShow :: Show PersistenceImpl where 19 | show = genericShow 20 | -------------------------------------------------------------------------------- /src/Server/Shell/Util/Aggregate.purs: -------------------------------------------------------------------------------- 1 | module Server.Shell.Util.Aggregate where 2 | 3 | import Prelude 4 | 5 | import Effect (Effect) 6 | import Server.Shared.Interface.Aggregate (Handle) 7 | import Server.Shell.Persistence.Postgres.Main as Postgres 8 | import Server.Shell.Type.Misc (Config) 9 | import Server.Shell.Type.PersistenceImpl (PersistenceImpl(..)) as PI 10 | import Server.Shell.Util.Token as Token 11 | 12 | mkHandle :: Config -> Effect Handle 13 | mkHandle config = do 14 | persistence <- case config.persistence.impl of 15 | PI.Postgres -> Postgres.mkHandle config.persistence 16 | pure 17 | { persistence 18 | , token: Token.mkHandle config.token 19 | } 20 | -------------------------------------------------------------------------------- /src/Server/Shell/Util/Config.purs: -------------------------------------------------------------------------------- 1 | module Server.Shell.Util.Config where 2 | 3 | import Prelude 4 | import Data.Either (Either(Right, Left)) 5 | import Data.Foldable (intercalate) 6 | import Effect.Aff (Aff) 7 | import Effect.Class (liftEffect) 8 | import Effect.Exception (throw) 9 | import Foreign (renderForeignError) 10 | import Node.Encoding (Encoding(..)) 11 | import Node.FS.Aff (readTextFile) 12 | import Node.Path (FilePath) 13 | import Server.Shell.Type.Misc (Config) 14 | import Simple.JSON as JSON 15 | 16 | read :: FilePath -> Aff (Either String Config) 17 | read = map parse <<< readTextFile UTF8 18 | where 19 | parse s = case JSON.readJSON s of 20 | Left e -> Left $ intercalate ".\n" $ renderForeignError <$> e 21 | Right a -> pure a 22 | 23 | readOrThrow :: FilePath -> Aff Config 24 | readOrThrow path = 25 | read path 26 | >>= case _ of 27 | Left e -> liftEffect $ throw e 28 | Right a -> pure a 29 | 30 | -------------------------------------------------------------------------------- /src/Server/Shell/Util/Token.purs: -------------------------------------------------------------------------------- 1 | module Server.Shell.Util.Token where 2 | 3 | import Prelude 4 | 5 | import Control.Error.Util (hush) 6 | import Data.DateTime (DateTime, adjust, modifyTime, setMillisecond) 7 | import Data.DateTime.Instant (toDateTime) 8 | import Data.Maybe (Maybe(..), fromMaybe) 9 | import Data.Newtype (unwrap, wrap) 10 | import Data.Time.Duration as Duration 11 | import Effect.Aff (Aff) 12 | import Effect.Class (class MonadEffect, liftEffect) 13 | import Effect.Now (now) 14 | import Node.Jwt as JWT 15 | import Server.Shared.Interface.Token (Handle) 16 | import Server.Shell.Type.Misc (TokenConfig) 17 | import Shared.Type.Misc (Token, UserId, Secret) 18 | import Timestamp (Timestamp) 19 | 20 | mkHandle :: TokenConfig -> Handle 21 | mkHandle { secret, timestamp } = 22 | { encode: encode secret timestamp 23 | , decode: pure <<< decode secret 24 | } 25 | 26 | type UnregisteredClaimsRow 27 | = ( id :: UserId 28 | ) 29 | 30 | type UnregisteredClaims 31 | = Record UnregisteredClaimsRow 32 | 33 | mkUnregisteredClaims :: UserId -> UnregisteredClaims 34 | mkUnregisteredClaims id = { id } 35 | 36 | decode :: Secret -> Token -> Maybe UserId 37 | decode secret token = 38 | let 39 | decodedToken = getVerifiedToken secret token 40 | 41 | unregisteredClaims = decodedToken <#> _.claims >>> _.unregisteredClaims 42 | in 43 | case unregisteredClaims of 44 | Nothing -> Nothing 45 | Just v1 -> case v1 of 46 | Nothing -> Nothing 47 | Just { id } -> Just id 48 | 49 | getVerifiedToken :: Secret -> String -> Maybe (JWT.Token UnregisteredClaimsRow JWT.Verified) 50 | getVerifiedToken secret token = hush $ JWT.verify (JWT.Secret secret) token 51 | 52 | unsafeAdjust :: DateTime -> DateTime 53 | unsafeAdjust = fromMaybe bottom <<< adjust (Duration.Hours 1.0) 54 | 55 | getTimestamp :: forall m. MonadEffect m => m DateTime 56 | getTimestamp = liftEffect $ modifyTime (setMillisecond bottom) <<< toDateTime <$> now 57 | 58 | encode :: Secret -> Maybe Timestamp -> UserId -> Aff Token 59 | encode secret mTimestamp userId = do 60 | timestamp <- case mTimestamp of 61 | Nothing -> getTimestamp 62 | Just value -> pure $ unwrap value 63 | expirationTime <- pure $ unsafeAdjust timestamp 64 | let 65 | claims = 66 | JWT.defaultClaims 67 | { exp = Just $ wrap expirationTime 68 | , iat = Just $ wrap timestamp 69 | , unregisteredClaims = Just $ mkUnregisteredClaims userId 70 | } 71 | token <- JWT.sign (JWT.Secret secret) JWT.defaultHeaders claims 72 | pure token 73 | -------------------------------------------------------------------------------- /src/Server/User/Api/Interface/Spec.purs: -------------------------------------------------------------------------------- 1 | module Server.User.Api.Interface.Spec where 2 | 3 | import Payload.Spec (DELETE, GET, POST, PUT, OPTIONS) 4 | import Payload.Spec (Routes) as Payload 5 | import Server.Shared.Api.Interface.Spec (AuthGuard, CorsGuard) 6 | import Server.Shared.Api.Type.Misc (WildcardParam) 7 | import Server.User.Api.Type.CreateDto (CreateDto) 8 | import Server.User.Api.Type.LoginDto (LoginDto) 9 | import Server.User.Api.Type.Misc (Dto) 10 | import Server.User.Api.Type.UpdateDto (UpdateDto) 11 | 12 | type Routes 13 | = Payload.Routes "/api" 14 | { guards :: CorsGuard 15 | , login :: 16 | POST "/users/login" 17 | { body :: LoginDto 18 | , response :: Dto 19 | } 20 | , create :: 21 | POST "/users" 22 | { body :: CreateDto 23 | , response :: Dto 24 | } 25 | , getCurrent :: 26 | GET "/user" 27 | { guards :: AuthGuard 28 | , response :: Dto 29 | } 30 | , update :: 31 | PUT "/user" 32 | { guards :: AuthGuard 33 | , body :: UpdateDto 34 | , response :: Dto 35 | } 36 | , delete :: 37 | DELETE "/user" 38 | { guards :: AuthGuard 39 | , response :: Dto 40 | } 41 | } 42 | -------------------------------------------------------------------------------- /src/Server/User/Api/Main.purs: -------------------------------------------------------------------------------- 1 | module Server.User.Api.Main where 2 | 3 | import Prelude 4 | import Data.Either (Either(..)) 5 | import Effect.Aff (Aff) 6 | import Payload.ResponseTypes (Response) 7 | import Payload.Server.Response (notFound, ok, unprocessableEntity) 8 | import Server.Shared.Api.Main (setHeaders, renderErrorEntity, renderErrorMessage) 9 | import Server.Shared.Api.Type.Misc (AuthGuard, CorsGuard, TResponse) 10 | import Server.Shared.Interface.Aggregate (Handle) 11 | import Server.Shared.Type.Misc (Pool(..)) 12 | import Server.User.Api.Type.CreateDto (CreateDto, unwrapCreateDto) 13 | import Server.User.Api.Type.LoginDto (LoginDto, unwrapLoginDto) 14 | import Server.User.Api.Type.Misc (Dto, mkDto) 15 | import Server.User.Api.Type.UpdateDto (UpdateDto, unwrapUpdateDto) 16 | import Server.User.Interface.Persistence (Handle) as Persistence 17 | import Server.User.Persistence.Postgres.Main (mkHandle) as Postgres 18 | import Server.User.Type.Misc (InputError(..), User) 19 | 20 | mkHandle :: Handle -> _ 21 | mkHandle h = 22 | { login: login h 23 | , create: create h 24 | , getCurrent: getCurrent h 25 | , update: update h 26 | , delete: delete h 27 | } 28 | 29 | next :: Handle -> Persistence.Handle 30 | next h = case h.persistence.pool of 31 | PostgresPool pool -> Postgres.mkHandle pool 32 | 33 | login :: Handle -> { body :: LoginDto, guards :: CorsGuard } -> Aff (TResponse Dto) 34 | login h { body: body, guards: g } = 35 | setHeaders g.origin 36 | <$> ((next h).findByCredentials (unwrapLoginDto body) >>= mkTResponse h) 37 | 38 | create :: Handle -> { body :: CreateDto, guards :: CorsGuard } -> Aff (TResponse Dto) 39 | create h { body: body, guards: g } = 40 | setHeaders g.origin 41 | <$> ((next h).insert (unwrapCreateDto body) >>= mkTResponse h) 42 | 43 | getCurrent :: Handle -> { guards :: AuthGuard } -> Aff (TResponse Dto) 44 | getCurrent h { guards: g } = 45 | setHeaders g.origin 46 | <$> ((next h).findById g.userId >>= mkTResponse h) 47 | 48 | update :: Handle -> { body :: UpdateDto, guards :: AuthGuard } -> Aff (TResponse Dto) 49 | update h { guards: g, body } = 50 | setHeaders g.origin 51 | <$> ((next h).update (unwrapUpdateDto body) g.userId >>= mkTResponse h) 52 | 53 | delete :: Handle -> { guards :: AuthGuard } -> Aff (TResponse Dto) 54 | delete h { guards: g } = 55 | setHeaders g.origin 56 | <$> ((next h).delete g.userId >>= mkTResponse h) 57 | 58 | mkTResponse :: Handle -> Either InputError User -> Aff (TResponse Dto) 59 | mkTResponse h appResult = case appResult of 60 | Left e -> pure $ Left $ renderError e 61 | Right user -> Right <$> ok <$> mkDto user <$> h.token.encode user.id 62 | 63 | renderError :: InputError -> Response String 64 | renderError EMAIL_EXISTS = unprocessableEntity $ renderErrorEntity "email" "exists" 65 | renderError USERNAME_EXISTS = unprocessableEntity $ renderErrorEntity "username" "exists" 66 | renderError NOT_FOUND = notFound $ renderErrorMessage "user not found" 67 | -------------------------------------------------------------------------------- /src/Server/User/Api/Type/CreateDto.purs: -------------------------------------------------------------------------------- 1 | module Server.User.Api.Type.CreateDto where 2 | 3 | import Prelude 4 | 5 | import Data.Bifunctor (lmap) 6 | import Data.Eq.Generic (genericEq) 7 | import Data.Generic.Rep (class Generic) 8 | import Data.Show.Generic (genericShow) 9 | import Foreign.Class (class Decode, class Encode) 10 | import Foreign.Generic (defaultOptions, genericDecode, genericEncode) 11 | import Payload.Server.DecodeBody (class DecodeBody) 12 | import Server.Shared.Api.Main (renderJsonErrors) 13 | import Server.User.Type.Misc (Raw) 14 | import Simple.JSON as SJ 15 | 16 | newtype CreateDto 17 | = CreateDto { user :: Raw } 18 | 19 | derive instance genericCreateDto :: Generic CreateDto _ 20 | 21 | instance showCreateDto :: Show CreateDto where 22 | show = genericShow 23 | 24 | instance eqCreateDto :: Eq CreateDto where 25 | eq = genericEq 26 | 27 | instance decodeCreateDto :: Decode CreateDto where 28 | decode = genericDecode $ defaultOptions { unwrapSingleConstructors = true } 29 | 30 | instance encodeCreateDto :: Encode CreateDto where 31 | encode = genericEncode $ defaultOptions { unwrapSingleConstructors = true } 32 | 33 | derive newtype instance readForeignCreateDto :: SJ.ReadForeign CreateDto 34 | 35 | derive newtype instance writeForeignCreateDto :: SJ.WriteForeign CreateDto 36 | 37 | instance decodeBodyCreateDto :: SJ.ReadForeign CreateDto => DecodeBody CreateDto where 38 | decodeBody = lmap renderJsonErrors <<< SJ.readJSON 39 | 40 | wrapCreateDto :: Raw -> CreateDto 41 | wrapCreateDto x = CreateDto { user: x } 42 | 43 | unwrapCreateDto :: CreateDto -> Raw 44 | unwrapCreateDto (CreateDto { user: x }) = x 45 | -------------------------------------------------------------------------------- /src/Server/User/Api/Type/LoginDto.purs: -------------------------------------------------------------------------------- 1 | module Server.User.Api.Type.LoginDto where 2 | 3 | import Prelude 4 | 5 | import Data.Bifunctor (lmap) 6 | import Data.Eq.Generic (genericEq) 7 | import Data.Generic.Rep (class Generic) 8 | import Data.Show.Generic (genericShow) 9 | import Foreign.Class (class Decode, class Encode) 10 | import Foreign.Generic (defaultOptions, genericDecode, genericEncode) 11 | import Payload.Server.DecodeBody (class DecodeBody) 12 | import Server.Shared.Api.Main (renderJsonErrors) 13 | import Server.User.Type.Misc (Credentials) 14 | import Simple.JSON as SJ 15 | 16 | newtype LoginDto 17 | = LoginDto { user :: Credentials } 18 | 19 | derive instance genericLoginDto :: Generic LoginDto _ 20 | 21 | instance showLoginDto :: Show LoginDto where 22 | show = genericShow 23 | 24 | instance eqLoginDto :: Eq LoginDto where 25 | eq = genericEq 26 | 27 | instance decodeLoginDto :: Decode LoginDto where 28 | decode = genericDecode $ defaultOptions { unwrapSingleConstructors = true } 29 | 30 | instance encodeLoginDto :: Encode LoginDto where 31 | encode = genericEncode $ defaultOptions { unwrapSingleConstructors = true } 32 | 33 | derive newtype instance readForeignLoginDto :: SJ.ReadForeign LoginDto 34 | derive newtype instance writeForeignLoginDto :: SJ.WriteForeign LoginDto 35 | 36 | instance decodeBodyLoginDto :: SJ.ReadForeign LoginDto => DecodeBody LoginDto where 37 | decodeBody = lmap renderJsonErrors <<< SJ.readJSON 38 | 39 | wrapLoginDto :: Credentials -> LoginDto 40 | wrapLoginDto x = LoginDto { user: x } 41 | 42 | unwrapLoginDto :: LoginDto -> Credentials 43 | unwrapLoginDto (LoginDto { user: x }) = x 44 | -------------------------------------------------------------------------------- /src/Server/User/Api/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.User.Api.Type.Misc where 2 | 3 | import Data.Either (Either) 4 | import Data.Maybe (Maybe) 5 | import Data.Nullable (Nullable, toNullable) 6 | import Payload.ResponseTypes (Failure) 7 | import Server.User.Type.Misc (User) 8 | import Shared.Type.Misc (Bio, Email, Image, Username, Token) 9 | 10 | type Dto 11 | = { user :: 12 | { bio :: Nullable Bio 13 | , email :: Email 14 | , image :: Nullable Image 15 | , token :: Token 16 | , username :: Username 17 | } 18 | } 19 | 20 | mkDto :: User -> Token -> Dto 21 | mkDto u token = 22 | { user: 23 | { bio: toNullable u.bio 24 | , email: u.email 25 | , image: toNullable u.image 26 | , token 27 | , username: u.username 28 | } 29 | } 30 | -------------------------------------------------------------------------------- /src/Server/User/Api/Type/UpdateDto.purs: -------------------------------------------------------------------------------- 1 | module Server.User.Api.Type.UpdateDto where 2 | 3 | import Prelude 4 | import Data.Bifunctor (lmap) 5 | import Data.Generic.Rep (class Generic) 6 | import Payload.Server.DecodeBody (class DecodeBody) 7 | import Server.Shared.Api.Main (renderJsonErrors) 8 | import Server.User.Type.Misc (Patch) 9 | import Simple.JSON as SJ 10 | import Data.Show.Generic (genericShow) 11 | import Data.Eq.Generic (genericEq) 12 | 13 | newtype UpdateDto 14 | = UpdateDto { user :: Patch } 15 | 16 | derive instance genericUpdateDto :: Generic UpdateDto _ 17 | 18 | instance showUpdateDto :: Show UpdateDto where 19 | show = genericShow 20 | 21 | instance eqUpdateDto :: Eq UpdateDto where 22 | eq = genericEq 23 | 24 | {- 25 | instance decodeUpdateDto :: Decode UpdateDto where 26 | decode = genericDecode $ defaultOptions { unwrapSingleConstructors = true } 27 | 28 | instance encodeUpdateDto :: Encode UpdateDto where 29 | encode = genericEncode $ defaultOptions { unwrapSingleConstructors = true } 30 | -} 31 | derive newtype instance readForeignUpdateDto :: SJ.ReadForeign UpdateDto 32 | 33 | derive newtype instance writeForeignUpdateDto :: SJ.WriteForeign UpdateDto 34 | 35 | instance decodeBodyUpdateDto :: SJ.ReadForeign UpdateDto => DecodeBody UpdateDto where 36 | decodeBody = lmap renderJsonErrors <<< SJ.readJSON 37 | 38 | wrapUpdateDto :: Patch -> UpdateDto 39 | wrapUpdateDto x = UpdateDto { user: x } 40 | 41 | unwrapUpdateDto :: UpdateDto -> Patch 42 | unwrapUpdateDto (UpdateDto { user: x }) = x 43 | -------------------------------------------------------------------------------- /src/Server/User/Interface/Persistence.purs: -------------------------------------------------------------------------------- 1 | module Server.User.Interface.Persistence where 2 | 3 | import Data.Either (Either) 4 | import Effect.Aff (Aff) 5 | import Server.User.Type.Misc (Credentials, InputError, Patch, Raw, User) 6 | import Shared.Type.Misc (Username, UserId) 7 | 8 | type Handle 9 | = { findByCredentials :: Credentials -> Aff (Either InputError User) 10 | , findByUsername :: Username -> Aff (Either InputError User) 11 | , findById :: UserId -> Aff (Either InputError User) 12 | , insert :: Raw -> Aff (Either InputError User) 13 | , update :: Patch -> UserId -> Aff (Either InputError User) 14 | , delete :: UserId -> Aff (Either InputError User) 15 | } 16 | -------------------------------------------------------------------------------- /src/Server/User/Persistence/Postgres/Main.purs: -------------------------------------------------------------------------------- 1 | -- | All functions are supposed to do what they say otherwise it is an input error or an 2 | -- | other kind of error. Input errors are returned others are thrown. 3 | module Server.User.Persistence.Postgres.Main where 4 | 5 | import Prelude 6 | 7 | import Data.Either (Either) 8 | import Data.Maybe (Maybe(..)) 9 | import Data.Nullable (toMaybe) 10 | import Database.PostgreSQL (Pool) 11 | import Effect.Aff (Aff) 12 | import Selda (Col, FullQuery, restrict, selectFrom, (.==)) 13 | import Selda.PG (litPG) 14 | import Selda.PG.Class (deleteFrom, insert1, query1) 15 | import Selda.PG.Class (update) as S 16 | import Selda.Query.Class (runSelda) 17 | import Server.Shared.Persistence.Postgres.Main (crypt, cryptGenSalt, withConnection) 18 | import Server.Shared.Persistence.Type.Misc (userTable) 19 | import Server.Shared.Util.Selda (query1_) 20 | import Server.User.Interface.Persistence (Handle) 21 | import Server.User.Persistence.Postgres.Type.Misc (DbOutputCols, encryptedTable) 22 | import Server.User.Persistence.Postgres.Validation (validateSingle) 23 | import Server.User.Type.Misc (Credentials, InputError, Patch, Raw, User) 24 | import Shared.Type.LongString (LongString) 25 | import Shared.Type.Misc (Email, Password, UserId, Username) 26 | 27 | mkHandle :: Pool -> Handle 28 | mkHandle p = 29 | { findByCredentials: findByCredentials p 30 | , findById: findById p 31 | , findByUsername: findByUsername p 32 | , insert: insert p 33 | , update: update p 34 | , delete: delete p 35 | } 36 | 37 | findByCredentials :: Pool -> Credentials -> Aff (Either InputError User) 38 | findByCredentials pool { email, password } = 39 | withConnection pool (\conn -> runSelda conn $ query1_ $ selectByCredentials email password) 40 | >>= validateSingle 41 | 42 | selectByCredentials :: forall s. Email -> Password -> FullQuery s (DbOutputCols s) 43 | selectByCredentials email password = 44 | selectFrom userTable \r -> do 45 | restrict $ r.email .== (litPG email) && r.password .== crypt (litPG password) r.password 46 | pure r 47 | 48 | selectByUsername :: forall s. Username -> FullQuery s (DbOutputCols s) 49 | selectByUsername username = 50 | selectFrom userTable \r -> do 51 | restrict $ r.username .== (litPG username) 52 | pure r 53 | 54 | -- | If the username is not found, it is an input error. 55 | findByUsername :: Pool -> Username -> Aff (Either InputError User) 56 | findByUsername pool username = 57 | withConnection pool (\conn -> runSelda conn $ query1_ $ selectByUsername username) 58 | >>= validateSingle 59 | 60 | selectById :: forall s. UserId -> FullQuery s (DbOutputCols s) 61 | selectById id = 62 | selectFrom userTable \r -> do 63 | restrict $ r.id .== (litPG id) 64 | pure r 65 | 66 | -- | If the userId is not found, it is an input error. 67 | findById :: Pool -> UserId -> Aff (Either InputError User) 68 | findById pool id = 69 | withConnection pool (\conn -> runSelda conn $ query1_ $ selectById id) 70 | >>= validateSingle 71 | 72 | selectPassword :: forall s. Password -> FullQuery s { password :: Col s LongString } 73 | selectPassword password = 74 | selectFrom (encryptedTable password) \r -> do 75 | pure r 76 | 77 | -- | If it could not be inserted, because constraints are not met, it is an input error. 78 | insert :: Pool -> Raw -> Aff (Either InputError User) 79 | insert pool r = 80 | withConnection pool 81 | ( \conn -> 82 | runSelda conn do 83 | encrypted <- query1_ $ selectPassword r.password 84 | insert1 userTable { bio: r.bio, email: r.email, image: r.image, password: encrypted.password, username: r.username } 85 | ) 86 | >>= validateSingle 87 | 88 | update :: Pool -> Patch -> UserId -> Aff (Either InputError User) 89 | update pool p id = 90 | withConnection pool 91 | ( \conn -> 92 | runSelda conn do 93 | S.update userTable 94 | (\r -> r.id .== litPG id) 95 | ( \r -> 96 | r 97 | { bio = 98 | case p.bio of 99 | Nothing -> r.bio 100 | Just defined -> litPG $ toMaybe defined 101 | , email = 102 | case p.email of 103 | Nothing -> r.email 104 | Just defined -> litPG defined 105 | , image = 106 | case p.image of 107 | Nothing -> r.image 108 | Just defined -> litPG $ toMaybe defined 109 | , password = 110 | case p.password of 111 | Nothing -> r.password 112 | Just defined -> cryptGenSalt (litPG defined) 113 | , username = 114 | case p.username of 115 | Nothing -> r.username 116 | Just defined -> litPG defined 117 | } 118 | ) 119 | query1_ $ selectById id 120 | ) 121 | >>= validateSingle 122 | 123 | delete :: Pool -> UserId -> Aff (Either InputError User) 124 | delete pool id = 125 | withConnection pool 126 | ( \conn -> 127 | runSelda conn do 128 | user <- query1_ $ selectById id 129 | _ <- deleteFrom userTable (\r -> r.id .== litPG id) 130 | pure user 131 | ) 132 | >>= validateSingle 133 | -------------------------------------------------------------------------------- /src/Server/User/Persistence/Postgres/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.User.Persistence.Postgres.Type.Misc where 2 | 3 | import Prelude 4 | import Data.Maybe (Maybe(..)) 5 | import Selda (Col, Table(..)) 6 | import Server.User.Type.Misc (Template, IdTemplate) 7 | import Shared.Type.LongString (LongString) 8 | import Shared.Type.LongString as LongString 9 | import Shared.Type.Misc (Password, Identity) 10 | 11 | type DbOutputCols s 12 | = { | Template (Col s) Maybe (IdTemplate (Col s) Identity) } 13 | 14 | encryptedTable :: Password -> Table ( password ∷ LongString ) 15 | encryptedTable password = 16 | Source "encrypted" 17 | $ do 18 | case _ of 19 | Nothing -> "\"encrypted\"" 20 | Just alias -> "crypt('" <> (LongString.toString password) <> "', gen_salt('bf'))" <> " " <> alias <> " (password)" 21 | -------------------------------------------------------------------------------- /src/Server/User/Persistence/Postgres/Validation.purs: -------------------------------------------------------------------------------- 1 | module Server.User.Persistence.Postgres.Validation where 2 | 3 | import Prelude 4 | import Control.Monad.Except (throwError) 5 | import Data.Either (Either(..)) 6 | import Database.PostgreSQL (PGError(..)) 7 | import Effect.Aff (Aff) 8 | import Effect.Exception (error) 9 | import Server.User.Type.Misc (InputError(..)) 10 | 11 | validateSingle :: forall a. Either PGError a -> Aff (Either InputError a) 12 | validateSingle result = do 13 | case result of 14 | Left e -> case e of 15 | IntegrityError detail -> case detail.constraint of 16 | "email_unique" -> pure $ Left EMAIL_EXISTS 17 | "username_unique" -> pure $ Left USERNAME_EXISTS 18 | otherwise -> throwError $ error $ show e 19 | -- | `query1_` Throws `ConversionError ∷ PGError` is case of no results. 20 | ConversionError _ -> pure $ Left NOT_FOUND 21 | otherwise -> throwError $ error $ show e 22 | Right a -> pure $ Right a 23 | -------------------------------------------------------------------------------- /src/Server/User/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Server.User.Type.Misc where 2 | 3 | import Data.Either (Either) 4 | import Data.Maybe (Maybe, fromMaybe) 5 | import Data.Nullable (Nullable) 6 | import Shared.Type.Misc (Bio, Email, Image, Password, UserId, Username, Identity) 7 | import Shared.Util.Maybe (fromMaybeNullable) 8 | 9 | type Credentials 10 | = { email :: Email 11 | , password :: Password 12 | } 13 | 14 | type Template col maybe r 15 | = ( bio :: col (maybe Bio) 16 | , email :: col Email 17 | , image :: col (maybe Image) 18 | , password :: col Password 19 | , username :: col Username 20 | | r 21 | ) 22 | 23 | type IdTemplate col key 24 | = ( id :: col (key UserId) ) 25 | 26 | --type Raw 27 | -- = { | Template Identity Maybe () } 28 | -- not possible because of https://github.com/purescript/purescript/issues/4105 29 | type Raw 30 | = { bio :: Maybe Bio 31 | , email :: Email 32 | , image :: Maybe Image 33 | , password :: Password 34 | , username :: Username 35 | } 36 | 37 | --type Patch 38 | -- = { | Template Maybe Nullable () } 39 | -- not possible because of https://github.com/purescript/purescript/issues/4105 40 | type Patch 41 | = { bio :: Maybe (Nullable Bio) 42 | , email :: Maybe Email 43 | , image :: Maybe (Nullable Image) 44 | , password :: Maybe Password 45 | , username :: Maybe Username 46 | } 47 | 48 | type User 49 | = { | Template Identity Maybe (IdTemplate Identity Identity) } 50 | 51 | mkRawFromPatch :: User -> Patch -> Raw 52 | mkRawFromPatch f p = 53 | { bio: fromMaybeNullable f.bio p.bio 54 | , email: fromMaybe f.email p.email 55 | , image: fromMaybeNullable f.image p.image 56 | , password: fromMaybe f.password p.password 57 | , username: fromMaybe f.username p.username 58 | } 59 | 60 | data InputError 61 | = EMAIL_EXISTS 62 | | USERNAME_EXISTS 63 | | NOT_FOUND 64 | -------------------------------------------------------------------------------- /src/Server/User/Type/Test.purs: -------------------------------------------------------------------------------- 1 | module Server.User.Type.Test where 2 | 3 | import Data.Either (Either) 4 | import Data.Maybe (Maybe, fromMaybe) 5 | import Data.Nullable (Nullable) 6 | import Shared.Type.Misc (Bio, Email, Image, Password, UserId, Username, Identity) 7 | import Shared.Util.Maybe (fromMaybeNullable) 8 | 9 | type Credentials 10 | = { email :: Email 11 | , password :: Password 12 | } 13 | 14 | type Template col maybe r 15 | = ( bio :: col (maybe Bio) 16 | , email :: col Email 17 | , image :: col (maybe Image) 18 | , password :: col Password 19 | , username :: col Username 20 | | r 21 | ) 22 | 23 | type IdTemplate col key 24 | = ( id :: col (key UserId) ) 25 | 26 | type Raw 27 | = { | Template Identity Maybe () } 28 | 29 | type Patch 30 | = { | Template Maybe Nullable () } 31 | 32 | type User 33 | = { | Template Identity Maybe (IdTemplate Identity Identity) } 34 | 35 | mkRawFromPatch :: User -> Patch -> Raw 36 | mkRawFromPatch f p = 37 | { bio: fromMaybeNullable f.bio p.bio 38 | , email: fromMaybe f.email p.email 39 | , image: fromMaybeNullable f.image p.image 40 | , password: fromMaybe f.password p.password 41 | , username: fromMaybe f.username p.username 42 | } 43 | 44 | data InputError 45 | = EMAIL_EXISTS 46 | | USERNAME_EXISTS 47 | | NOT_FOUND 48 | -------------------------------------------------------------------------------- /src/Shared/Type/LongString.purs: -------------------------------------------------------------------------------- 1 | module Shared.Type.LongString (fromString, toString, LongString) where 2 | 3 | import Prelude 4 | import Control.Monad.Except (except, runExcept) 5 | import Data.Bifunctor (lmap) 6 | import Data.Either (Either(..)) 7 | import Data.Generic.Rep (class Generic) 8 | import Data.Show.Generic (genericShow) 9 | import Data.String (length, toLower) 10 | import Database.PostgreSQL (class FromSQLValue, class ToSQLValue) 11 | import Foreign (F, Foreign, ForeignError(..), unsafeToForeign) 12 | import Foreign.Class (class Decode, class Encode) 13 | import Foreign.Generic (defaultOptions, genericDecode, genericEncode) 14 | import Payload.Server.Params (class DecodeParam) 15 | import Simple.JSON as JSON 16 | 17 | newtype LongString 18 | = LongString String 19 | 20 | fromString :: String -> Either String LongString 21 | fromString s = 22 | let 23 | len = length s 24 | in 25 | case unit of 26 | _ 27 | | len == 0 -> Left "can't be empty" 28 | _ 29 | | len > 1000 -> Left "can't be longer than 1000 characters" 30 | _ -> Right (LongString s) 31 | 32 | -- | A partial version of `fromString`. 33 | -- unsafeFromString :: Partial => String -> LongString 34 | -- unsafeFromString = fromRight <<< fromString 35 | toString :: LongString -> String 36 | toString (LongString s) = s 37 | 38 | derive instance genericLongString :: Generic LongString _ 39 | 40 | instance showLongString :: Show LongString where 41 | show = genericShow 42 | 43 | instance eqLongString :: Eq LongString where 44 | eq o1 o2 = (toLower (toString o1)) == (toLower (toString o2)) 45 | 46 | instance decodeLongString :: Decode LongString where 47 | decode = genericDecode $ defaultOptions { unwrapSingleConstructors = true } 48 | 49 | instance encodeLongString :: Encode LongString where 50 | encode = genericEncode $ defaultOptions { unwrapSingleConstructors = true } 51 | 52 | instance readForeignLongString :: JSON.ReadForeign LongString where 53 | readImpl = fromForeign 54 | 55 | fromForeign :: Foreign -> F LongString 56 | fromForeign f = do 57 | str :: String <- JSON.readImpl f 58 | except case fromString str of 59 | Left e -> Left $ pure $ ForeignError e 60 | Right a -> Right a 61 | 62 | instance writeForeignLongString :: JSON.WriteForeign LongString where 63 | writeImpl = toForeign 64 | 65 | toForeign :: LongString -> Foreign 66 | toForeign = unsafeToForeign <<< toString 67 | 68 | instance decodeParamLongString :: DecodeParam LongString where 69 | decodeParam = fromString 70 | 71 | instance fromSqlValueLongString :: FromSQLValue LongString where 72 | fromSQLValue = lmap show <<< runExcept <<< fromForeign 73 | 74 | instance toSQLValueLongString :: ToSQLValue LongString where 75 | toSQLValue = toForeign 76 | -------------------------------------------------------------------------------- /src/Shared/Type/LowercaseString.purs: -------------------------------------------------------------------------------- 1 | module Shared.Type.LowercaseString (fromString, LowercaseString) where 2 | 3 | import Prelude 4 | import Control.Monad.Except (except, runExcept) 5 | import Data.Bifunctor (lmap) 6 | import Data.Either (Either(..), either, fromRight) 7 | import Data.Eq.Generic (genericEq) 8 | import Data.Generic.Rep (class Generic) 9 | import Data.Maybe (Maybe(..)) 10 | import Data.Show.Generic (genericShow) 11 | import Data.String (Pattern(..), Replacement(..), length, replaceAll, toLower, trim) 12 | import Data.String.Regex (regex, replace) 13 | import Data.String.Regex.Flags (global) 14 | import Database.PostgreSQL (class FromSQLValue, class ToSQLValue) 15 | import Foreign (F, Foreign, ForeignError(..), unsafeToForeign) 16 | import Foreign.Class (class Decode, class Encode) 17 | import Foreign.Generic (defaultOptions, genericDecode, genericEncode) 18 | import Foreign.Object as Object 19 | import Partial.Unsafe (unsafeCrashWith) 20 | import Payload.Server.Internal.Querystring (ParsedQuery) 21 | import Payload.Server.Params (class DecodeParam) 22 | import Payload.Server.QueryParams (class DecodeQueryParam, DecodeError(..)) 23 | import Simple.JSON as JSON 24 | 25 | newtype LowercaseString 26 | = LowercaseString String 27 | 28 | fromString :: String -> Either String LowercaseString 29 | fromString s = 30 | let 31 | i = mkIdentifier s 32 | 33 | len = length i 34 | in 35 | case unit of 36 | _ 37 | | len == 0 -> Left "can't be empty" 38 | _ 39 | | len > 50 -> Left "can't be longer than 50 characters" 40 | _ -> Right $ LowercaseString i 41 | 42 | mkIdentifier :: String -> String 43 | mkIdentifier = 44 | replaceAll (Pattern " ") (Replacement "-") 45 | <<< replace theRegex "" 46 | <<< toLower 47 | <<< trim 48 | where 49 | theRegex = regex "[^ a-z0-9_.:-]" global # either unsafeCrashWith identity 50 | 51 | -- | A partial version of `fromString`. 52 | -- unsafeFromString :: Partial => String -> LowercaseString 53 | -- unsafeFromString = fromRight <<< fromString 54 | toString :: LowercaseString -> String 55 | toString (LowercaseString s) = s 56 | 57 | derive instance genericLowercaseString :: Generic LowercaseString _ 58 | 59 | instance showLowercaseString :: Show LowercaseString where 60 | show = genericShow 61 | 62 | instance eqLowercaseString :: Eq LowercaseString where 63 | eq = genericEq 64 | 65 | instance decodeLowercaseString :: Decode LowercaseString where 66 | decode = genericDecode $ defaultOptions { unwrapSingleConstructors = true } 67 | 68 | instance encodeLowercaseString :: Encode LowercaseString where 69 | encode = genericEncode $ defaultOptions { unwrapSingleConstructors = true } 70 | 71 | instance readForeignLowercaseString :: JSON.ReadForeign LowercaseString where 72 | readImpl = fromForeign 73 | 74 | fromForeign :: Foreign -> F LowercaseString 75 | fromForeign f = do 76 | str :: String <- JSON.readImpl f 77 | except case fromString str of 78 | Left e -> Left $ pure $ ForeignError e 79 | Right a -> Right a 80 | 81 | instance writeForeignLowercaseString :: JSON.WriteForeign LowercaseString where 82 | writeImpl = toForeign 83 | 84 | toForeign :: LowercaseString -> Foreign 85 | toForeign = unsafeToForeign <<< toString 86 | 87 | instance decodeParamLowercaseString :: DecodeParam LowercaseString where 88 | decodeParam = fromString <<< toLower 89 | 90 | instance decodeQueryParamString :: DecodeQueryParam LowercaseString where 91 | decodeQueryParam = decodeQueryParam 92 | 93 | decodeQueryParam :: ParsedQuery -> String -> Either DecodeError LowercaseString 94 | decodeQueryParam queryObj queryKey = case Object.lookup queryKey queryObj of 95 | Nothing -> Left (QueryParamNotFound { key: queryKey, queryObj }) 96 | Just [] -> decodeErr [] $ "Expected single value but received empty Array" 97 | Just [ str ] -> case fromString (toLower str) of 98 | Left e -> decodeErr [] $ e 99 | Right a -> Right a 100 | Just arr -> decodeErr arr $ "Expected single value but received multiple: " <> show arr 101 | where 102 | decodeErr values msg = Left (QueryDecodeError { key: queryKey, values, message: msg, queryObj }) 103 | 104 | instance fromSqlValueLowercaseString :: FromSQLValue LowercaseString where 105 | fromSQLValue = lmap show <<< runExcept <<< fromForeign 106 | 107 | instance toSQLValueLowercaseString :: ToSQLValue LowercaseString where 108 | toSQLValue = toForeign 109 | -------------------------------------------------------------------------------- /src/Shared/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Shared.Type.Misc where 2 | 3 | import Data.Maybe (Maybe) 4 | import Shared.Type.LongString (LongString) 5 | import Shared.Type.LowercaseString (LowercaseString) 6 | import Shared.Type.ShortString (ShortString) 7 | import Timestamp (Timestamp) 8 | 9 | type ArticleId 10 | = Int 11 | 12 | type Bio 13 | = LongString 14 | 15 | type Body 16 | = LongString 17 | 18 | type CommentId 19 | = Int 20 | 21 | type CreatedAt 22 | = Timestamp 23 | 24 | type Description 25 | = LongString 26 | 27 | type Email 28 | = ShortString 29 | 30 | type Favorited 31 | = Boolean 32 | 33 | type FavoritesCount 34 | = Int 35 | 36 | type FolloweeUsername 37 | = ShortString 38 | 39 | type FollowerId 40 | = UserId 41 | 42 | type Following 43 | = Boolean 44 | 45 | type Image 46 | = LongString 47 | 48 | type Limit 49 | = Int 50 | 51 | type Offset 52 | = Int 53 | 54 | type Password 55 | = LongString 56 | 57 | type Secret 58 | = String 59 | 60 | type Slug 61 | = LowercaseString 62 | 63 | type Tag 64 | = LowercaseString 65 | 66 | type Title 67 | = ShortString 68 | 69 | type Token 70 | = String 71 | 72 | type UpdatedAt 73 | = Timestamp 74 | 75 | type Username 76 | = ShortString 77 | 78 | type UserId 79 | = Int 80 | 81 | type AuthorTemplate col 82 | = ( bio :: col (Maybe Bio) 83 | , following :: col Following 84 | , image :: col (Maybe Image) 85 | , username :: col Username 86 | ) 87 | 88 | type Author 89 | = { | AuthorTemplate Identity } 90 | 91 | type Identity a 92 | = a 93 | -------------------------------------------------------------------------------- /src/Shared/Type/ShortString.purs: -------------------------------------------------------------------------------- 1 | module Shared.Type.ShortString where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Except (except, runExcept) 6 | import Data.Bifunctor (lmap) 7 | import Data.Either (Either(..), fromRight) 8 | import Data.Generic.Rep (class Generic) 9 | import Data.Maybe (Maybe(..)) 10 | import Data.Show.Generic (genericShow) 11 | import Data.String (length, toLower) 12 | import Database.PostgreSQL (class FromSQLValue, class ToSQLValue) 13 | import Foreign (F, Foreign, ForeignError(..), unsafeToForeign) 14 | import Foreign.Class (class Decode, class Encode) 15 | import Foreign.Generic (defaultOptions, genericDecode, genericEncode) 16 | import Foreign.Object as Object 17 | import Payload.Server.Internal.Querystring (ParsedQuery) 18 | import Payload.Server.Params (class DecodeParam) 19 | import Payload.Server.QueryParams (class DecodeQueryParam, DecodeError(..)) 20 | import Simple.JSON as JSON 21 | 22 | newtype ShortString 23 | = ShortString String 24 | 25 | fromString :: String -> Either String ShortString 26 | fromString s = 27 | let 28 | len = length s 29 | in 30 | case unit of 31 | _ 32 | | len == 0 -> Left "can't be empty" 33 | _ 34 | | len > 50 -> Left "can't be longer than 50 characters" 35 | _ -> Right (ShortString s) 36 | 37 | -- | A partial version of `fromString`. 38 | -- unsafeFromString :: Partial => String -> ShortString 39 | -- unsafeFromString = fromRight <<< fromString 40 | 41 | toString :: ShortString -> String 42 | toString (ShortString s) = s 43 | 44 | derive instance genericShortString :: Generic ShortString _ 45 | 46 | instance showShortString :: Show ShortString where 47 | show = genericShow 48 | 49 | instance eqShortString :: Eq ShortString where 50 | eq o1 o2 = (toLower (toString o1)) == (toLower (toString o2)) 51 | 52 | instance decodeShortString :: Decode ShortString where 53 | decode = genericDecode $ defaultOptions { unwrapSingleConstructors = true } 54 | 55 | instance encodeShortString :: Encode ShortString where 56 | encode = genericEncode $ defaultOptions { unwrapSingleConstructors = true } 57 | 58 | instance readForeignShortString :: JSON.ReadForeign ShortString where 59 | readImpl = fromForeign 60 | 61 | fromForeign :: Foreign -> F ShortString 62 | fromForeign f = do 63 | str :: String <- JSON.readImpl f 64 | except case fromString str of 65 | Left e -> Left $ pure $ ForeignError e 66 | Right a -> Right a 67 | 68 | instance writeForeignShortString :: JSON.WriteForeign ShortString where 69 | writeImpl = toForeign 70 | 71 | toForeign :: ShortString -> Foreign 72 | toForeign = unsafeToForeign <<< toString 73 | 74 | instance decodeParamShortString :: DecodeParam ShortString where 75 | decodeParam = fromString <<< toLower 76 | 77 | instance decodeQueryParamString :: DecodeQueryParam ShortString where 78 | decodeQueryParam = decodeQueryParam 79 | 80 | decodeQueryParam :: ParsedQuery -> String -> Either DecodeError ShortString 81 | decodeQueryParam queryObj queryKey = case Object.lookup queryKey queryObj of 82 | Nothing -> Left (QueryParamNotFound { key: queryKey, queryObj }) 83 | Just [] -> decodeErr [] $ "Expected single value but received empty Array" 84 | Just [ str ] -> case fromString (toLower str) of 85 | Left e -> decodeErr [] $ e 86 | Right a -> Right a 87 | Just arr -> decodeErr arr $ "Expected single value but received multiple: " <> show arr 88 | where 89 | decodeErr values msg = Left (QueryDecodeError { key: queryKey, values, message: msg, queryObj }) 90 | 91 | instance fromSqlValueShortString :: FromSQLValue ShortString where 92 | fromSQLValue = lmap show <<< runExcept <<< fromForeign 93 | 94 | instance toSQLValueProductType :: ToSQLValue ShortString where 95 | toSQLValue = toForeign 96 | -------------------------------------------------------------------------------- /src/Shared/Util/Maybe.purs: -------------------------------------------------------------------------------- 1 | module Shared.Util.Maybe where 2 | 3 | import Data.Maybe (Maybe(..)) 4 | import Data.Nullable (Nullable, toMaybe) 5 | 6 | -- | Converts defined, `Just a` to `Just a`, anything else to `Nothing`. 7 | fromMaybeNullable :: forall a. Maybe a -> Maybe (Nullable a) -> Maybe a 8 | fromMaybeNullable fallback value = case value of 9 | Just defined -> toMaybe defined 10 | Nothing -> fallback 11 | -------------------------------------------------------------------------------- /src/Shared/Util/String.purs: -------------------------------------------------------------------------------- 1 | module Shared.Util.String where 2 | 3 | import Data.String (Pattern(..), Replacement(..), replaceAll) 4 | 5 | format1 :: String -> String -> String 6 | format1 str x1 = replaceAll (Pattern "{1}") (Replacement x1) str 7 | 8 | format2 :: String -> String -> String -> String 9 | format2 str x1 x2 = 10 | let 11 | str1 = format1 str x1 12 | in 13 | replaceAll (Pattern "{2}") (Replacement x2) str1 14 | 15 | format3 :: String -> String -> String -> String -> String 16 | format3 str x1 x2 x3 = 17 | let 18 | str2 = format2 str x1 x2 19 | in 20 | replaceAll (Pattern "{3}") (Replacement x3) str2 21 | 22 | format4 :: String -> String -> String -> String -> String -> String 23 | format4 str x1 x2 x3 x4 = 24 | let 25 | str3 = format3 str x1 x2 x3 26 | in 27 | replaceAll (Pattern "{4}") (Replacement x4) str3 28 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Data.Unit (Unit) 4 | import Effect (Effect) 5 | import Test.Server.Shell.Main as Shell 6 | 7 | main :: Effect Unit 8 | main = Shell.main 9 | -------------------------------------------------------------------------------- /test/ResetTables.purs: -------------------------------------------------------------------------------- 1 | module Test.ResetTables where 2 | 3 | import Prelude 4 | 5 | import Effect (Effect) 6 | import Effect.Aff (launchAff_) 7 | import Effect.Class (liftEffect) 8 | import Node.Encoding (Encoding(..)) 9 | import Node.FS.Aff (readTextFile) 10 | import Server.Shell.Util.Aggregate as Aggregate 11 | import Server.Shell.Util.Config (readOrThrow) 12 | import Test.Server.Shell.Persistence.Postgres.Main (resetDB) 13 | 14 | main :: Effect Unit 15 | main = 16 | launchAff_ do 17 | config <- readOrThrow "./config/Server/Dev.json" 18 | sql <- readTextFile UTF8 "./sql/ResetTables.sql" 19 | h1 <- liftEffect $ Aggregate.mkHandle config 20 | pure $ resetDB h1.persistence.pool sql 21 | -------------------------------------------------------------------------------- /test/Server/Article/CreateJimSuccessRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "article": { 3 | "title": "Alt", 4 | "description": "how?", 5 | "body": "go", 6 | "tagList": [ 7 | "alt" 8 | ] 9 | } 10 | } -------------------------------------------------------------------------------- /test/Server/Article/CreateSuccessRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "article": { 3 | "title": "How to train your dragon", 4 | "description": "Ever wonder how?", 5 | "body": "You have to believe", 6 | "tagList": [ 7 | "reactJs", 8 | "angularJs", 9 | "dragons" 10 | ] 11 | } 12 | } -------------------------------------------------------------------------------- /test/Server/Article/Multiple0Response.json: -------------------------------------------------------------------------------- 1 | { 2 | "articlesCount": 0, 3 | "articles": [] 4 | } -------------------------------------------------------------------------------- /test/Server/Article/Multiple2Response.json: -------------------------------------------------------------------------------- 1 | { 2 | "articlesCount": 2, 3 | "articles": [ 4 | { 5 | "updatedAt": "2016-02-18T02:22:56Z", 6 | "title": "How to train your dragon", 7 | "tagList": [ 8 | "reactjs", 9 | "angularjs", 10 | "dragons" 11 | ], 12 | "slug": "how-to-train-your-dragon", 13 | "favoritesCount": 0, 14 | "favorited": false, 15 | "description": "Ever wonder how?", 16 | "createdAt": "2016-02-18T02:22:56Z", 17 | "body": "You have to believe", 18 | "author": { 19 | "username": "jake", 20 | "image": null, 21 | "following": false, 22 | "bio": "I work at statefarm" 23 | } 24 | }, 25 | { 26 | "updatedAt": "2016-02-18T02:22:56Z", 27 | "title": "Alt", 28 | "tagList": [ 29 | "alt" 30 | ], 31 | "slug": "alt", 32 | "favoritesCount": 0, 33 | "favorited": false, 34 | "description": "how?", 35 | "createdAt": "2016-02-18T02:22:56Z", 36 | "body": "go", 37 | "author": { 38 | "username": "jim", 39 | "image": null, 40 | "following": false, 41 | "bio": "I work at statefarm" 42 | } 43 | } 44 | ] 45 | } -------------------------------------------------------------------------------- /test/Server/Article/MultipleJakeResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "articlesCount": 1, 3 | "articles": [ 4 | { 5 | "updatedAt": "2016-02-18T02:22:56Z", 6 | "title": "How to train your dragon", 7 | "tagList": [ 8 | "reactjs", 9 | "angularjs", 10 | "dragons" 11 | ], 12 | "slug": "how-to-train-your-dragon", 13 | "favoritesCount": 0, 14 | "favorited": false, 15 | "description": "Ever wonder how?", 16 | "createdAt": "2016-02-18T02:22:56Z", 17 | "body": "You have to believe", 18 | "author": { 19 | "username": "jake", 20 | "following": false, 21 | "bio": "I work at statefarm", 22 | "image": null 23 | } 24 | } 25 | ] 26 | } -------------------------------------------------------------------------------- /test/Server/Article/MultipleJimFavoritedResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "articlesCount": 1, 3 | "articles": [ 4 | { 5 | "updatedAt": "2016-02-18T02:22:56Z", 6 | "title": "Alt", 7 | "tagList": [ 8 | "alt" 9 | ], 10 | "slug": "alt", 11 | "favoritesCount": 1, 12 | "favorited": false, 13 | "description": "how?", 14 | "createdAt": "2016-02-18T02:22:56Z", 15 | "body": "go", 16 | "author": { 17 | "username": "jim", 18 | "image": null, 19 | "following": false, 20 | "bio": "I work at statefarm" 21 | } 22 | } 23 | ] 24 | } -------------------------------------------------------------------------------- /test/Server/Article/MultipleJimFollowingResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "articlesCount": 1, 3 | "articles": [ 4 | { 5 | "updatedAt": "2016-02-18T02:22:56Z", 6 | "title": "Alt", 7 | "tagList": [ 8 | "alt" 9 | ], 10 | "slug": "alt", 11 | "favoritesCount": 0, 12 | "favorited": false, 13 | "description": "how?", 14 | "createdAt": "2016-02-18T02:22:56Z", 15 | "body": "go", 16 | "author": { 17 | "username": "jim", 18 | "following": true, 19 | "bio": "I work at statefarm", 20 | "image": null 21 | } 22 | } 23 | ] 24 | } -------------------------------------------------------------------------------- /test/Server/Article/MultipleJimResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "articlesCount": 1, 3 | "articles": [ 4 | { 5 | "updatedAt": "2016-02-18T02:22:56Z", 6 | "title": "Alt", 7 | "tagList": [ 8 | "alt" 9 | ], 10 | "slug": "alt", 11 | "favoritesCount": 0, 12 | "favorited": false, 13 | "description": "how?", 14 | "createdAt": "2016-02-18T02:22:56Z", 15 | "body": "go", 16 | "author": { 17 | "username": "jim", 18 | "following": false, 19 | "bio": "I work at statefarm", 20 | "image": null 21 | } 22 | } 23 | ] 24 | } -------------------------------------------------------------------------------- /test/Server/Article/SingleJimResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "articlesCount": 1, 3 | "articles": [ 4 | { 5 | "updatedAt": "2016-02-18T02:22:56Z", 6 | "title": "Alt", 7 | "tagList": [ 8 | "alt" 9 | ], 10 | "slug": "alt", 11 | "favoritesCount": 0, 12 | "favorited": false, 13 | "description": "how?", 14 | "createdAt": "2016-02-18T02:22:56Z", 15 | "body": "go", 16 | "author": { 17 | "username": "jim", 18 | "following": false, 19 | "bio": "I work at statefarm" 20 | } 21 | } 22 | ] 23 | } -------------------------------------------------------------------------------- /test/Server/Article/SingleResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "article": { 3 | "updatedAt": "2016-02-18T02:22:56Z", 4 | "title": "How to train your dragon", 5 | "tagList": [ 6 | "reactjs", 7 | "angularjs", 8 | "dragons" 9 | ], 10 | "slug": "how-to-train-your-dragon", 11 | "favoritesCount": 0, 12 | "favorited": false, 13 | "description": "Ever wonder how?", 14 | "createdAt": "2016-02-18T02:22:56Z", 15 | "body": "You have to believe", 16 | "author": { 17 | "username": "jake", 18 | "image": null, 19 | "following": false, 20 | "bio": "I work at statefarm" 21 | } 22 | } 23 | } -------------------------------------------------------------------------------- /test/Server/Article/TagsResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "tags": [ 3 | "alt", 4 | "angularjs", 5 | "dragons", 6 | "reactjs" 7 | ] 8 | } -------------------------------------------------------------------------------- /test/Server/Article/UpdateBackSuccessRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "article": { 3 | "title": "How to train your dragon" 4 | } 5 | } -------------------------------------------------------------------------------- /test/Server/Article/UpdateSuccessRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "article": { 3 | "title": "Did you train your dragon?" 4 | } 5 | } -------------------------------------------------------------------------------- /test/Server/Article/UpdateSuccessResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "article": { 3 | "updatedAt": "2016-02-18T02:22:56Z", 4 | "title": "Did you train your dragon?", 5 | "tagList": [ 6 | "reactjs", 7 | "angularjs", 8 | "dragons" 9 | ], 10 | "slug": "did-you-train-your-dragon", 11 | "favoritesCount": 0, 12 | "favorited": false, 13 | "description": "Ever wonder how?", 14 | "createdAt": "2016-02-18T02:22:56Z", 15 | "body": "You have to believe", 16 | "author": { 17 | "username": "jake", 18 | "image": null, 19 | "following": false, 20 | "bio": "I work at statefarm" 21 | } 22 | } 23 | } -------------------------------------------------------------------------------- /test/Server/Comment/CreateSuccessRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "comment": { 3 | "body": "His name was my name too." 4 | } 5 | } -------------------------------------------------------------------------------- /test/Server/Comment/MultipleResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "comments": [ 3 | { 4 | "updatedAt": "2016-02-18T02:22:56Z", 5 | "id": 1, 6 | "createdAt": "2016-02-18T02:22:56Z", 7 | "body": "His name was my name too.", 8 | "author": { 9 | "username": "jake", 10 | "following": false, 11 | "bio": "I work at statefarm" 12 | } 13 | } 14 | ] 15 | } -------------------------------------------------------------------------------- /test/Server/Comment/SingleResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "comment": { 3 | "updatedAt": "2016-02-18T02:22:56Z", 4 | "id": 1, 5 | "createdAt": "2016-02-18T02:22:56Z", 6 | "body": "His name was my name too.", 7 | "author": { 8 | "username": "jake", 9 | "image": null, 10 | "following": false, 11 | "bio": "I work at statefarm" 12 | } 13 | } 14 | } -------------------------------------------------------------------------------- /test/Server/Profile/FollowFail422Response.json: -------------------------------------------------------------------------------- 1 | { 2 | "errors": { 3 | "message": [ 4 | "follower must be different from followee" 5 | ] 6 | } 7 | } -------------------------------------------------------------------------------- /test/Server/Profile/FollowSuccessResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "profile": { 3 | "bio": "I work at statefarm", 4 | "following": true, 5 | "image": null, 6 | "username": "jim" 7 | } 8 | } -------------------------------------------------------------------------------- /test/Server/Profile/GetSuccessResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "profile": { 3 | "bio": "I work at statefarm", 4 | "following": false, 5 | "image": null, 6 | "username": "jim" 7 | } 8 | } -------------------------------------------------------------------------------- /test/Server/Profile/RequestFail404Response.json: -------------------------------------------------------------------------------- 1 | { 2 | "errors": { 3 | "message": [ 4 | "profile not found" 5 | ] 6 | } 7 | } -------------------------------------------------------------------------------- /test/Server/Profile/UnfollowSuccessResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "profile": { 3 | "bio": "I work at statefarm", 4 | "following": false, 5 | "image": null, 6 | "username": "jim" 7 | } 8 | } -------------------------------------------------------------------------------- /test/Server/Shell/Interface/Api.purs: -------------------------------------------------------------------------------- 1 | module Test.Server.Shell.Interface.Api where 2 | 3 | import Data.Maybe (Maybe) 4 | import Data.Unit (Unit) 5 | import Effect.Aff (Aff) 6 | import Test.Server.Shell.Util.Payload (ApiResponse) 7 | 8 | type Call 9 | = String -> Maybe String -> Maybe String -> Aff ApiResponse 10 | 11 | type Handle 12 | = { withApi :: Aff Unit -> Aff Unit 13 | , get :: Call 14 | , post :: Call 15 | , put :: Call 16 | , delete :: Call 17 | } 18 | -------------------------------------------------------------------------------- /test/Server/Shell/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Server.Shell.Main where 2 | 3 | import Prelude 4 | import Control.Monad.Except (throwError) 5 | import Data.Array (filter) 6 | import Data.Either (Either(Right, Left)) 7 | import Data.Foldable (intercalate, traverse_) 8 | import Data.Maybe (Maybe(..), fromMaybe) 9 | import Data.Traversable (traverse) 10 | import Data.Tuple (Tuple(..)) 11 | import Effect (Effect) 12 | import Effect.Aff (Aff, launchAff_) 13 | import Effect.Class (liftEffect) 14 | import Effect.Exception (error, throw) 15 | import Foreign (renderForeignError) 16 | import Node.Encoding (Encoding(..)) 17 | import Node.FS.Aff (readTextFile) 18 | import Node.HTTP (Request) 19 | import Node.Path (FilePath, concat) 20 | import Payload.Headers (Headers) 21 | import Payload.Headers (fromFoldable, empty) as P 22 | import Payload.ResponseTypes (Response(..)) 23 | import Server.Shared.Api.Type.Misc (Origin) 24 | import Server.Shell.Api.Interface.Spec (spec) as Api 25 | import Server.Shell.Api.Main (mkHandle) as Api 26 | import Server.Shell.Type.Misc (Config) 27 | import Server.Shell.Util.Aggregate as Aggregate 28 | import Server.Shell.Util.Config (readOrThrow) as Config 29 | import Shared.Util.String (format1, format2) 30 | import Simple.JSON as JSON 31 | import Test.Server.Shell.Interface.Api (Handle) 32 | import Test.Server.Shell.Persistence.Postgres.Main (resetDB) 33 | import Test.Server.Shell.Type.Misc (Raw, TestCase) 34 | import Test.Server.Shell.Type.Misc (WithApi) 35 | import Test.Server.Shell.Util.Payload (delete_, get_, post_, put_, respMatchesJson, withServer) as P 36 | import Test.Unit (TestSuite, suite, test) 37 | import Test.Unit.Assert as Assert 38 | import Test.Unit.Main (runTestWith) 39 | import Test.Unit.Output.Fancy (runTest) 40 | 41 | read :: FilePath -> Aff (Either String (Array Raw)) 42 | read = map parse <<< readTextFile UTF8 43 | where 44 | parse s = case JSON.readJSON s of 45 | Left e -> Left $ intercalate ".\n" $ renderForeignError <$> e 46 | Right a -> pure a 47 | 48 | readOrThrow :: FilePath -> Aff (Array Raw) 49 | readOrThrow path = 50 | read path 51 | >>= case _ of 52 | Left e -> liftEffect $ throw e 53 | Right a -> pure a 54 | 55 | readBody :: FilePath -> String -> String -> Aff String 56 | readBody path domain bodyFilename = readTextFile UTF8 $ concat [ path, domain, bodyFilename <> ".json" ] 57 | 58 | mkTestCase :: FilePath -> Raw -> Aff TestCase 59 | mkTestCase path r = 60 | let 61 | requestBodyFilename = (\id -> concat [ path, r.domain, id ]) <$> r.request.bodyFilename 62 | 63 | responseBodyFilename = (\id -> concat [ path, r.domain, id ]) <$> r.response.bodyFilename 64 | in 65 | do 66 | requestBody <- readTextFile UTF8 `traverse` requestBodyFilename 67 | responseBody <- readTextFile UTF8 `traverse` responseBodyFilename 68 | pure 69 | { description: r.description 70 | , domain: r.domain 71 | , request: 72 | { body: requestBody 73 | , bodyFilename: requestBodyFilename 74 | , method: r.request.method 75 | , path: r.request.path 76 | , token: r.request.token 77 | } 78 | , response: 79 | { body: responseBody 80 | , bodyFilename: responseBodyFilename 81 | , status: r.response.status 82 | } 83 | } 84 | 85 | fakeAuthOrigin :: Request -> Aff (Either (Response String) Origin) 86 | fakeAuthOrigin req = pure $ Right "http://example.com" 87 | 88 | main :: Effect Unit 89 | main = 90 | launchAff_ do 91 | config <- Config.readOrThrow "./config/Server/Dev.json" 92 | rs <- readOrThrow "./test/Server/Shell/TestCases.json" 93 | activeRs <- pure $ filter (\r -> r.x == Nothing || r.x == Just false) rs 94 | ts <- mkTestCase "./test/Server" `traverse` activeRs 95 | h1 <- liftEffect $ Aggregate.mkHandle config 96 | sql <- readTextFile UTF8 "./sql/ResetTables.sql" 97 | resetDB h1.persistence.pool sql 98 | runTestWith runTest do 99 | let 100 | apiImpl = Api.mkHandle h1 101 | 102 | apiMock = 103 | { handlers: apiImpl.handlers 104 | , guards: 105 | { userId: apiImpl.guards.userId 106 | , maybeUserId: apiImpl.guards.maybeUserId 107 | , origin: fakeAuthOrigin 108 | } 109 | } 110 | 111 | withApi = P.withServer Api.spec apiMock 112 | 113 | h2 = mkHandle withApi config 114 | suite "Tests" do 115 | runTestCase h2 `traverse_` ts 116 | 117 | runTestCase :: Handle -> TestCase -> TestSuite 118 | runTestCase h t = 119 | test description 120 | $ h.withApi do 121 | aResponse <- method t.request.path t.request.body t.request.token 122 | matches t.response.status t.response.body aResponse 123 | where 124 | method = case t.request.method of 125 | "get" -> h.get 126 | "post" -> h.post 127 | "put" -> h.put 128 | "delete" -> h.delete 129 | s -> (\_ _ _ -> throwError $ error (format1 "method {1} not found." s)) 130 | 131 | matches = case t.response.body of 132 | Nothing -> (\status _ actual -> Assert.equal status actual.status) 133 | Just body -> (\status _ -> P.respMatchesJson { status, body }) 134 | 135 | -- verbose 136 | description = intercalate " " [ t.domain, t.request.method, t.request.path, (show t.response.status), fromMaybe "" t.description, fromMaybe "" t.response.bodyFilename ] 137 | 138 | --non-verbose 139 | --description = intercalate " " [ t.request.method, t.request.path, fromMaybe "" t.description ] 140 | mkHandle :: WithApi -> Config -> Handle 141 | mkHandle withApi config = 142 | { withApi 143 | , get: (\path _ token -> P.get_ host path (toHeader token)) 144 | , post: (\path body token -> P.post_ host path (toHeader token) body) 145 | , put: (\path body token -> P.put_ host path (toHeader token) body) 146 | , delete: (\path body token -> P.delete_ host path (toHeader token) body) 147 | } 148 | where 149 | host = format2 "http://{1}:{2}" config.server.hostname (show config.server.port) 150 | 151 | toHeader :: Maybe String -> Headers 152 | toHeader token = case token of 153 | Nothing -> P.empty 154 | Just t -> P.fromFoldable [ Tuple "Authorization" t ] 155 | -------------------------------------------------------------------------------- /test/Server/Shell/Persistence/Postgres.purs: -------------------------------------------------------------------------------- 1 | module Test.Server.Shell.Persistence.Postgres.Main where 2 | 3 | import Prelude 4 | import Control.Monad.Error.Class (throwError) 5 | import Data.Maybe (maybe) 6 | import Database.PostgreSQL (Query(..), Row0(..), execute) 7 | import Effect.Aff (Aff, error) 8 | import Server.Shared.Persistence.Postgres.Main (withConnection) 9 | import Server.Shared.Type.Misc (Pool(..)) 10 | 11 | resetDB :: Pool -> String -> Aff Unit 12 | resetDB (PostgresPool pool) sql = 13 | withConnection pool (\conn -> execute conn (Query sql) Row0) 14 | >>= maybe (pure unit) (throwError <<< error <<< show) 15 | -------------------------------------------------------------------------------- /test/Server/Shell/TestCases.json: -------------------------------------------------------------------------------- 1 | [ 2 | { 3 | "description": "Register jake", 4 | "domain": "User", 5 | "request": { 6 | "path": "/api/users", 7 | "method": "post", 8 | "bodyFilename": "RegisterSuccessRequest.json" 9 | }, 10 | "response": { 11 | "status": 200, 12 | "bodyFilename": "RequestSuccessResponse.json" 13 | } 14 | }, 15 | { 16 | "domain": "User", 17 | "request": { 18 | "path": "/api/users/login", 19 | "method": "post", 20 | "bodyFilename": "LoginSuccessRequest.json" 21 | }, 22 | "response": { 23 | "status": 200, 24 | "bodyFilename": "RequestSuccessResponse.json" 25 | } 26 | }, 27 | { 28 | "domain": "User", 29 | "request": { 30 | "path": "/api/users/login", 31 | "method": "post", 32 | "bodyFilename": "LoginFail404Request.json" 33 | }, 34 | "response": { 35 | "status": 404, 36 | "bodyFilename": "LoginFail404Response.json" 37 | } 38 | }, 39 | { 40 | "domain": "User", 41 | "request": { 42 | "path": "/api/users/login", 43 | "method": "post", 44 | "bodyFilename": "LoginFail400EmptyFieldRequest.json" 45 | }, 46 | "response": { 47 | "status": 400, 48 | "bodyFilename": "LoginFail400EmptyFieldResponse.json" 49 | } 50 | }, 51 | { 52 | "domain": "User", 53 | "request": { 54 | "path": "/api/users/login", 55 | "method": "post", 56 | "bodyFilename": "LoginFail400MissingFieldRequest.json" 57 | }, 58 | "response": { 59 | "status": 400, 60 | "bodyFilename": "LoginFail400MissingFieldResponse.json" 61 | } 62 | }, 63 | { 64 | "domain": "User", 65 | "request": { 66 | "path": "/api/user", 67 | "method": "get", 68 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 69 | }, 70 | "response": { 71 | "status": 200, 72 | "bodyFilename": "RequestSuccessResponse.json" 73 | } 74 | }, 75 | { 76 | "domain": "User", 77 | "request": { 78 | "path": "/api/user", 79 | "method": "put", 80 | "bodyFilename": "UpdateSuccessRequest.json", 81 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 82 | }, 83 | "response": { 84 | "status": 200, 85 | "bodyFilename": "RequestJimSuccessResponse.json" 86 | } 87 | }, 88 | { 89 | "description": "Reverse update", 90 | "domain": "User", 91 | "request": { 92 | "path": "/api/user", 93 | "method": "put", 94 | "bodyFilename": "UpdateBackSuccessRequest.json", 95 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 96 | }, 97 | "response": { 98 | "status": 200 99 | } 100 | }, 101 | { 102 | "domain": "User", 103 | "description": "Register jim", 104 | "request": { 105 | "path": "/api/users", 106 | "method": "post", 107 | "bodyFilename": "RegisterJimSuccessRequest.json" 108 | }, 109 | "response": { 110 | "status": 200 111 | } 112 | }, 113 | { 114 | "domain": "Profile", 115 | "request": { 116 | "path": "/api/profiles/jim", 117 | "method": "get" 118 | }, 119 | "response": { 120 | "status": 200, 121 | "bodyFilename": "GetSuccessResponse.json" 122 | } 123 | }, 124 | { 125 | "description": "shows an unfollowed profile", 126 | "domain": "Profile", 127 | "request": { 128 | "path": "/api/profiles/jim", 129 | "method": "get" 130 | }, 131 | "response": { 132 | "status": 200, 133 | "bodyFilename": "GetSuccessResponse.json" 134 | } 135 | }, 136 | { 137 | "description": "fails because nobody does not exist", 138 | "domain": "Profile", 139 | "request": { 140 | "path": "/api/profiles/nobody", 141 | "method": "get" 142 | }, 143 | "response": { 144 | "status": 404, 145 | "bodyFilename": "RequestFail404Response.json" 146 | } 147 | }, 148 | { 149 | "description": "follows jim", 150 | "domain": "Profile", 151 | "request": { 152 | "path": "/api/profiles/jim/follow", 153 | "method": "post", 154 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 155 | }, 156 | "response": { 157 | "status": 200, 158 | "bodyFilename": "FollowSuccessResponse.json" 159 | } 160 | }, 161 | { 162 | "description": "fails because of follower=followee", 163 | "domain": "Profile", 164 | "request": { 165 | "path": "/api/profiles/jake/follow", 166 | "method": "post", 167 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 168 | }, 169 | "response": { 170 | "status": 422, 171 | "bodyFilename": "FollowFail422Response.json" 172 | } 173 | }, 174 | { 175 | "description": "unfollows jim", 176 | "domain": "Profile", 177 | "request": { 178 | "path": "/api/profiles/jim/follow", 179 | "method": "delete", 180 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 181 | }, 182 | "response": { 183 | "status": 200, 184 | "bodyFilename": "UnfollowSuccessResponse.json" 185 | } 186 | }, 187 | { 188 | "description": "jake posts", 189 | "domain": "Article", 190 | "request": { 191 | "path": "/api/articles", 192 | "method": "post", 193 | "bodyFilename": "CreateSuccessRequest.json", 194 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 195 | }, 196 | "response": { 197 | "status": 200, 198 | "bodyFilename": "SingleResponse.json" 199 | } 200 | }, 201 | { 202 | "description": "jim posts", 203 | "domain": "Article", 204 | "request": { 205 | "path": "/api/articles", 206 | "method": "post", 207 | "bodyFilename": "CreateJimSuccessRequest.json", 208 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjJ9.qljK8m23kwkwi9meZhbt11CeYCvdd9F55_1RJWZ-ggs" 209 | }, 210 | "response": { 211 | "status": 200 212 | } 213 | }, 214 | { 215 | "description": "find 1 article from jim and jake each", 216 | "domain": "Article", 217 | "request": { 218 | "path": "/api/articles", 219 | "method": "get" 220 | }, 221 | "response": { 222 | "status": 200, 223 | "bodyFilename": "Multiple2Response.json" 224 | } 225 | }, 226 | { 227 | "description": "find 1 article from jake", 228 | "domain": "Article", 229 | "request": { 230 | "path": "/api/articles?tag=AngularJS", 231 | "method": "get" 232 | }, 233 | "response": { 234 | "status": 200, 235 | "bodyFilename": "MultipleJakeResponse.json" 236 | } 237 | }, 238 | { 239 | "description": "find 1 article from jim", 240 | "domain": "Article", 241 | "request": { 242 | "path": "/api/articles?author=jim", 243 | "method": "get" 244 | }, 245 | "response": { 246 | "status": 200, 247 | "bodyFilename": "MultipleJimResponse.json" 248 | } 249 | }, 250 | { 251 | "description": "get 0 new feeds because of no following", 252 | "domain": "Article", 253 | "request": { 254 | "path": "/api/articles/feed", 255 | "method": "get", 256 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 257 | }, 258 | "response": { 259 | "status": 200, 260 | "bodyFilename": "Multiple0Response.json" 261 | } 262 | }, 263 | { 264 | "description": "follows jim for next test", 265 | "domain": "Profile", 266 | "request": { 267 | "path": "/api/profiles/jim/follow", 268 | "method": "post", 269 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 270 | }, 271 | "response": { 272 | "status": 200 273 | } 274 | }, 275 | { 276 | "description": "get 1 new feeds because of following jim", 277 | "domain": "Article", 278 | "request": { 279 | "path": "/api/articles/feed", 280 | "method": "get", 281 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 282 | }, 283 | "response": { 284 | "status": 200, 285 | "bodyFilename": "MultipleJimFollowingResponse.json" 286 | } 287 | }, 288 | { 289 | "description": "reverts following", 290 | "domain": "Profile", 291 | "request": { 292 | "path": "/api/profiles/jim/follow", 293 | "method": "delete", 294 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 295 | }, 296 | "response": { 297 | "status": 200 298 | } 299 | }, 300 | { 301 | "description": "favor jim's article for next test", 302 | "domain": "Article", 303 | "request": { 304 | "path": "/api/articles/alt/favorite", 305 | "method": "post", 306 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 307 | }, 308 | "response": { 309 | "status": 200 310 | } 311 | }, 312 | { 313 | "description": "1 article from jim", 314 | "domain": "Article", 315 | "request": { 316 | "path": "/api/articles?favorited=jake", 317 | "method": "get" 318 | }, 319 | "response": { 320 | "status": 200, 321 | "bodyFilename": "MultipleJimFavoritedResponse.json" 322 | } 323 | }, 324 | { 325 | "description": "unfavor jim's article for next test", 326 | "domain": "Article", 327 | "request": { 328 | "path": "/api/articles/alt/favorite", 329 | "method": "delete", 330 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 331 | }, 332 | "response": { 333 | "status": 200 334 | } 335 | }, 336 | { 337 | "description": "0 articles favored", 338 | "domain": "Article", 339 | "request": { 340 | "path": "/api/articles?favorited=jake", 341 | "method": "get" 342 | }, 343 | "response": { 344 | "status": 200, 345 | "bodyFilename": "Multiple0Response.json" 346 | } 347 | }, 348 | { 349 | "domain": "Article", 350 | "request": { 351 | "path": "/api/articles/how-to-train-your-dragon", 352 | "method": "put", 353 | "bodyFilename": "UpdateSuccessRequest.json", 354 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 355 | }, 356 | "response": { 357 | "status": 200, 358 | "bodyFilename": "UpdateSuccessResponse.json" 359 | } 360 | }, 361 | { 362 | "description": "reverses update", 363 | "domain": "Article", 364 | "request": { 365 | "path": "/api/articles/did-you-train-your-dragon", 366 | "method": "put", 367 | "bodyFilename": "UpdateBackSuccessRequest.json", 368 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 369 | }, 370 | "response": { 371 | "status": 200 372 | } 373 | }, 374 | { 375 | "description": "gets the tags", 376 | "domain": "Article", 377 | "request": { 378 | "path": "/api/tags", 379 | "method": "get" 380 | }, 381 | "response": { 382 | "bodyFilename": "TagsResponse.json", 383 | "status": 200 384 | } 385 | }, 386 | { 387 | "description": "Delete jim's article", 388 | "domain": "Article", 389 | "request": { 390 | "path": "/api/articles/alt", 391 | "method": "delete", 392 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjJ9.qljK8m23kwkwi9meZhbt11CeYCvdd9F55_1RJWZ-ggs" 393 | }, 394 | "response": { 395 | "status": 200 396 | } 397 | }, 398 | { 399 | "description": "1 comment", 400 | "domain": "Comment", 401 | "request": { 402 | "path": "/api/articles/how-to-train-your-dragon/comments", 403 | "method": "post", 404 | "bodyFilename": "CreateSuccessRequest.json", 405 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 406 | }, 407 | "response": { 408 | "status": 200, 409 | "bodyFilename": "SingleResponse.json" 410 | } 411 | }, 412 | { 413 | "description": "Show created comment", 414 | "domain": "Comment", 415 | "request": { 416 | "path": "/api/articles/how-to-train-your-dragon/comments", 417 | "method": "get", 418 | "bodyFilename": "CreateSuccessRequest.json" 419 | }, 420 | "response": { 421 | "status": 200, 422 | "bodyFilename": "MultipleResponse.json" 423 | } 424 | }, 425 | { 426 | "domain": "Comment", 427 | "request": { 428 | "path": "/api/articles/how-to-train-your-dragon/comments/1", 429 | "method": "delete", 430 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo" 431 | }, 432 | "response": { 433 | "status": 200 434 | } 435 | } 436 | ] -------------------------------------------------------------------------------- /test/Server/Shell/Type/Misc.purs: -------------------------------------------------------------------------------- 1 | module Test.Server.Shell.Type.Misc where 2 | 3 | import Prelude 4 | import Data.Maybe (Maybe) 5 | import Effect.Aff (Aff) 6 | 7 | type WithApi 8 | = Aff Unit -> Aff Unit 9 | 10 | type Raw 11 | = { description :: Maybe String 12 | , domain :: String 13 | , request :: 14 | { bodyFilename :: Maybe String 15 | , method :: String 16 | , path :: String 17 | , token :: Maybe String 18 | } 19 | , response :: 20 | { status :: Int 21 | , bodyFilename :: Maybe String 22 | } 23 | , x :: Maybe Boolean 24 | } 25 | 26 | type TestCase 27 | = { description :: Maybe String 28 | , domain :: String 29 | , request :: 30 | { body :: Maybe String 31 | , path :: String 32 | , method :: String 33 | , token :: Maybe String 34 | , bodyFilename :: Maybe String 35 | } 36 | , response :: 37 | { status :: Int 38 | , body :: Maybe String 39 | , bodyFilename :: Maybe String 40 | } 41 | } 42 | -------------------------------------------------------------------------------- /test/Server/Shell/Util/Payload.purs: -------------------------------------------------------------------------------- 1 | module Test.Server.Shell.Util.Payload where 2 | 3 | import Prelude 4 | import Affjax as AX 5 | import Affjax.RequestBody as RequestBody 6 | import Affjax.RequestHeader (RequestHeader(..)) 7 | import Affjax.ResponseFormat as ResponseFormat 8 | import Affjax.ResponseHeader (ResponseHeader(..)) 9 | import Affjax.StatusCode (StatusCode(..)) 10 | import Control.Monad.Except (except, runExceptT) 11 | import Data.Argonaut (jsonParser) 12 | import Data.Either (Either(..)) 13 | import Data.HTTP.Method (Method(..)) 14 | import Data.Map (Map) 15 | import Data.Map as Map 16 | import Data.Maybe (Maybe(..)) 17 | import Data.Tuple (Tuple(..)) 18 | import Effect.Aff (Aff, error, throwError) 19 | import Effect.Aff as Aff 20 | import Payload.Client.Response (ClientResponse) 21 | import Payload.Headers (Headers) 22 | import Payload.Headers as Headers 23 | import Payload.ResponseTypes (Response(..)) 24 | import Payload.Server as Payload 25 | import Payload.Server.Routable (class Routable) 26 | import Payload.Spec (Spec(Spec)) 27 | import Test.Unit (Test, failure, success) 28 | import Test.Unit.Assert as Assert 29 | 30 | withServer :: 31 | forall routesSpec guardsSpec handlers guards. 32 | Routable routesSpec guardsSpec handlers guards => 33 | Spec { routes :: routesSpec, guards :: guardsSpec } -> 34 | { handlers :: handlers, guards :: guards } -> 35 | Aff Unit -> 36 | Aff Unit 37 | withServer apiSpec api_ aff = do 38 | let 39 | opts = Payload.defaultOpts { logLevel = Payload.LogError, port = 3000 } 40 | whileServerRuns (Payload.startGuarded opts apiSpec api_) aff 41 | 42 | whileServerRuns :: 43 | Aff (Either String Payload.Server) -> 44 | Aff Unit -> 45 | Aff Unit 46 | whileServerRuns runServer doWhileRunning = do 47 | Aff.bracket runServer completed runAff 48 | pure unit 49 | where 50 | runAff (Left e) = Aff.throwError (Aff.error e) 51 | 52 | runAff (Right _) = doWhileRunning 53 | 54 | completed (Left _) = pure unit 55 | 56 | completed (Right server) = Payload.close server 57 | 58 | withRoutes :: 59 | forall routesSpec handlers. 60 | Routable routesSpec {} handlers {} => 61 | Spec routesSpec -> 62 | handlers -> 63 | Aff Unit -> 64 | Aff Unit 65 | withRoutes _ handlers = 66 | withServer (Spec :: Spec { guards :: {}, routes :: routesSpec }) 67 | { guards: {}, handlers } 68 | 69 | type ApiResponse 70 | = { status :: Int 71 | , body :: String 72 | , headers :: Map String String 73 | } 74 | 75 | type RequestClient 76 | = { get :: String -> Aff ApiResponse 77 | , options :: String -> Aff ApiResponse 78 | , post :: String -> String -> Aff ApiResponse 79 | , put :: String -> String -> Aff ApiResponse 80 | , delete :: String -> Maybe String -> Aff ApiResponse 81 | , head :: String -> Aff ApiResponse 82 | } 83 | 84 | request :: String -> RequestClient 85 | request host = 86 | { get: get host 87 | , options: options host 88 | , post: post host 89 | , put: put host 90 | , delete: delete host 91 | , head: head host 92 | } 93 | 94 | get :: String -> String -> Aff ApiResponse 95 | get host path = AX.get ResponseFormat.string (host <> "/" <> path) >>= decodeResponse 96 | 97 | get_ :: String -> String -> Headers -> Aff ApiResponse 98 | get_ host path headers = AX.request req >>= decodeResponse 99 | where 100 | req = 101 | AX.defaultRequest 102 | { method = Left GET 103 | , url = host <> "/" <> path 104 | , responseFormat = ResponseFormat.string 105 | , headers = (\(Tuple name val) -> RequestHeader name val) <$> Headers.toUnfoldable headers 106 | } 107 | 108 | options :: String -> String -> Aff ApiResponse 109 | options host path = do 110 | let 111 | url = host <> "/" <> path 112 | let 113 | req = 114 | AX.defaultRequest 115 | { method = Left OPTIONS 116 | , url = url 117 | , responseFormat = ResponseFormat.string 118 | } 119 | result <- AX.request req 120 | decodeResponse result 121 | 122 | post :: String -> String -> String -> Aff ApiResponse 123 | post host path reqBody = AX.post ResponseFormat.string (host <> path) (Just body) >>= decodeResponse 124 | where 125 | body = RequestBody.String reqBody 126 | 127 | -- | Function did not exist in the original source 128 | post_ :: String -> String -> Headers -> Maybe String -> Aff ApiResponse 129 | post_ host path headers reqBody = AX.request req >>= decodeResponse 130 | where 131 | req = 132 | AX.defaultRequest 133 | { content = RequestBody.String <$> reqBody 134 | , method = Left POST 135 | , url = host <> "/" <> path 136 | , responseFormat = ResponseFormat.string 137 | , headers = (\(Tuple name val) -> RequestHeader name val) <$> Headers.toUnfoldable headers 138 | } 139 | 140 | put :: String -> String -> String -> Aff ApiResponse 141 | put host path reqBody = do 142 | let 143 | body = Just $ RequestBody.String reqBody 144 | result <- AX.put ResponseFormat.string (host <> "/" <> path) body 145 | decodeResponse result 146 | 147 | -- | Function did not exist in the original source 148 | put_ :: String -> String -> Headers -> Maybe String -> Aff ApiResponse 149 | put_ host path headers reqBody = AX.request req >>= decodeResponse 150 | where 151 | req = 152 | AX.defaultRequest 153 | { content = RequestBody.String <$> reqBody 154 | , method = Left PUT 155 | , url = host <> "/" <> path 156 | , responseFormat = ResponseFormat.string 157 | , headers = (\(Tuple name val) -> RequestHeader name val) <$> Headers.toUnfoldable headers 158 | } 159 | 160 | delete :: String -> String -> Maybe String -> Aff ApiResponse 161 | delete host path reqBody = do 162 | let 163 | content = RequestBody.String <$> reqBody 164 | let 165 | url = host <> "/" <> path 166 | let 167 | req = 168 | AX.defaultRequest 169 | { method = Left DELETE 170 | , url = url 171 | , content = content 172 | , responseFormat = ResponseFormat.string 173 | } 174 | result <- AX.request req 175 | decodeResponse result 176 | 177 | -- | Function did not exist in the original source 178 | delete_ :: String -> String -> Headers -> Maybe String -> Aff ApiResponse 179 | delete_ host path headers reqBody = AX.request req >>= decodeResponse 180 | where 181 | req = 182 | AX.defaultRequest 183 | { content = RequestBody.String <$> reqBody 184 | , method = Left DELETE 185 | , url = host <> "/" <> path 186 | , responseFormat = ResponseFormat.string 187 | , headers = (\(Tuple name val) -> RequestHeader name val) <$> Headers.toUnfoldable headers 188 | } 189 | 190 | head :: String -> String -> Aff ApiResponse 191 | head host path = AX.request req >>= decodeResponse 192 | where 193 | req = 194 | AX.defaultRequest 195 | { method = Left HEAD 196 | , responseFormat = ResponseFormat.string 197 | , url = host <> "/" <> path 198 | } 199 | 200 | decodeResponse :: Either AX.Error (AX.Response String) -> Aff ApiResponse 201 | decodeResponse (Right res) = pure (decodeBody res) 202 | 203 | decodeResponse (Left err) = throwError (error $ AX.printError err) 204 | 205 | decodeBody :: AX.Response String -> ApiResponse 206 | decodeBody res = 207 | { status: unwrapStatusCode res.status 208 | , body: res.body 209 | , headers: Map.fromFoldable $ unwrapHeader <$> res.headers 210 | } 211 | where 212 | unwrapHeader (ResponseHeader name value) = Tuple name value 213 | 214 | unwrapStatusCode :: StatusCode -> Int 215 | unwrapStatusCode (StatusCode c) = c 216 | 217 | respMatches :: { status :: Int, body :: String } -> ApiResponse -> Test 218 | respMatches expected received = Assert.equal expected { status: received.status, body: received.body } 219 | 220 | respMatchesStatus :: Int -> ApiResponse -> Test 221 | respMatchesStatus expected received = Assert.equal expected received.status 222 | 223 | -- | The original function just compares string bodies, this function parses 224 | -- | first and then compares. 225 | respMatchesJson :: { status :: Int, body :: String } -> ApiResponse -> Test 226 | respMatchesJson expected received = do 227 | Assert.equal expected.status received.status 228 | assertBodyEquals expected.body received.body 229 | 230 | assertBodyEquals :: String -> String -> Aff Unit 231 | assertBodyEquals s1 s2 = do 232 | result <- 233 | runExceptT do 234 | j1 <- except $ jsonParser s1 235 | j2 <- except $ jsonParser s2 236 | pure $ j1 == j2 237 | case result of 238 | Left err -> throwError (error $ "Could not parse body: " <> show err) 239 | Right value -> Assert.assert ("Expected " <> s1 <> ", got " <> s2) value 240 | 241 | bodyEquals :: forall body. Eq body => Show body => body -> ClientResponse body -> Aff Unit 242 | bodyEquals expected (Right (Response { body })) = Assert.equal expected body 243 | 244 | bodyEquals _ (Left err) = throwError (error $ "Expected body, received: " <> show err) 245 | 246 | assertRes :: forall a err. Show err => Eq a => Show a => Aff (Either err a) -> a -> Test 247 | assertRes req expected = do 248 | res <- req 249 | case res of 250 | Right val -> Assert.equal expected val 251 | Left errors -> failure $ "Request failed: " <> show errors 252 | 253 | assertOk :: forall a err. Show err => Aff (Either err a) -> Test 254 | assertOk req = do 255 | res <- req 256 | case res of 257 | Right _ -> success 258 | Left errors -> failure $ "Request failed: " <> show errors 259 | 260 | assertFail :: forall a err. Aff (Either err a) -> Test 261 | assertFail req = do 262 | res <- req 263 | case res of 264 | Right _ -> failure $ "Expected failure but request succeeded" 265 | Left errors -> success 266 | -------------------------------------------------------------------------------- /test/Server/User/LoginFail400EmptyFieldRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "user": { 3 | "email": "", 4 | "password": "" 5 | } 6 | } -------------------------------------------------------------------------------- /test/Server/User/LoginFail400EmptyFieldResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "errors": { 3 | "email": [ 4 | "can't be empty" 5 | ], 6 | "password": [ 7 | "can't be empty" 8 | ] 9 | } 10 | } -------------------------------------------------------------------------------- /test/Server/User/LoginFail400MissingFieldRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "user": {} 3 | } -------------------------------------------------------------------------------- /test/Server/User/LoginFail400MissingFieldResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "errors": { 3 | "email": [ 4 | "missing" 5 | ], 6 | "password": [ 7 | "missing" 8 | ] 9 | } 10 | } -------------------------------------------------------------------------------- /test/Server/User/LoginFail404Request.json: -------------------------------------------------------------------------------- 1 | { 2 | "user": { 3 | "email": "a@c", 4 | "password": "password" 5 | } 6 | } -------------------------------------------------------------------------------- /test/Server/User/LoginFail404Response.json: -------------------------------------------------------------------------------- 1 | { 2 | "errors": { 3 | "message": [ 4 | "user not found" 5 | ] 6 | } 7 | } -------------------------------------------------------------------------------- /test/Server/User/LoginJimSuccessRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "user": { 3 | "email": "jim@jim.jim", 4 | "password": "jim" 5 | } 6 | } -------------------------------------------------------------------------------- /test/Server/User/LoginSuccessRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "user": { 3 | "email": "jake@jake.jake", 4 | "password": "jake" 5 | } 6 | } -------------------------------------------------------------------------------- /test/Server/User/RegisterJimSuccessRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "user": { 3 | "bio": "I work at statefarm", 4 | "username": "jim", 5 | "email": "jim@jim.jim", 6 | "password": "jim" 7 | } 8 | } -------------------------------------------------------------------------------- /test/Server/User/RegisterSuccessRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "user": { 3 | "bio": "I work at statefarm", 4 | "username": "jake", 5 | "email": "jake@jake.jake", 6 | "password": "jake" 7 | } 8 | } -------------------------------------------------------------------------------- /test/Server/User/RequestJimSuccessResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "user": { 3 | "bio": "I work at statefarm", 4 | "email": "jim@jjim.jim", 5 | "image": null, 6 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo", 7 | "username": "jim" 8 | } 9 | } -------------------------------------------------------------------------------- /test/Server/User/RequestSuccessResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "user": { 3 | "bio": "I work at statefarm", 4 | "email": "jake@jake.jake", 5 | "image": null, 6 | "token": "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJpYXQiOjE4OTM0NTYwMDAsImV4cCI6MTg5MzQ1OTYwMCwiaWQiOjF9.JQvMz3rD-dhVLz3ooHBob5quAZHkBMAHKAShNv1-BMo", 7 | "username": "jake" 8 | } 9 | } -------------------------------------------------------------------------------- /test/Server/User/UpdateBackSuccessRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "user": { 3 | "username": "jake", 4 | "image": null, 5 | "email": "jake@jake.jake", 6 | "bio": "I work at statefarm" 7 | } 8 | } -------------------------------------------------------------------------------- /test/Server/User/UpdateSuccessRequest.json: -------------------------------------------------------------------------------- 1 | { 2 | "user": { 3 | "username": "jim", 4 | "image": null, 5 | "email": "jim@jjim.jim", 6 | "bio": "I work at statefarm" 7 | } 8 | } -------------------------------------------------------------------------------- /test/Server/User/UpdateSuccessResponse.json: -------------------------------------------------------------------------------- 1 | { 2 | "user": { 3 | "username": "jim", 4 | "image": null, 5 | "email": "jim@jjim.jim", 6 | "bio": "I work at statefarm" 7 | } 8 | } --------------------------------------------------------------------------------