├── .dockerignore ├── .gitignore ├── Dockerfile ├── LICENSE ├── Makefile ├── README.md ├── app └── Main.hs ├── docker-compose.yml ├── hie.yaml ├── package.yaml ├── scripts └── pg.sql ├── shell.nix ├── src ├── Adapter │ ├── EmailChecker.hs │ ├── Fake │ │ ├── Hasher.hs │ │ ├── Logger.hs │ │ └── UUID.hs │ ├── Http │ │ ├── Lib.hs │ │ ├── Scotty │ │ │ ├── LoginUser.hs │ │ │ ├── RegisterUser.hs │ │ │ └── Router.hs │ │ └── Servant │ │ │ ├── LoginUser.hs │ │ │ ├── RegisterUser.hs │ │ │ └── Router.hs │ ├── Logger.hs │ ├── Storage │ │ ├── Hasql │ │ │ └── User.hs │ │ └── InMem │ │ │ └── User.hs │ └── UUIDGen.hs ├── Config │ └── Config.hs ├── Domain │ ├── Messages.hs │ └── User.hs └── Usecase │ ├── Interactor.hs │ ├── LogicHandler.hs │ ├── UserLogin.hs │ └── UserRegistration.hs ├── stack.yaml ├── stack.yaml.lock └── test ├── Http ├── Lib.hs ├── ScottySpec.hs ├── ServantSpec.hs ├── Specs │ ├── Health.hs │ ├── LoginUser.hs │ └── RegisterUser.hs └── Utils.hs ├── Spec.hs ├── Storage ├── HasqlSpec.hs ├── Lib.hs └── Specs │ └── User.hs ├── Usecase ├── Lib.hs ├── Specs │ ├── UserLoginSpec.hs │ └── UserRegistrationSpec.hs └── Utils.hs └── Utils.hs /.dockerignore: -------------------------------------------------------------------------------- 1 | .git/ 2 | .gitignore 3 | 4 | Dockerfile 5 | docker-compose.yml 6 | .dockerignore 7 | 8 | dist-newstyle/ 9 | 10 | Makefile 11 | README.md 12 | LICENSE 13 | shell.nix 14 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | haskell-clean-architecture.cabal 2 | dist-newstyle 3 | app-exe 4 | .stack-work 5 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM utdemir/ghc-musl:v19-ghc8104 AS build-env 2 | 3 | # update package managers, install builder deps 4 | RUN cabal update 5 | RUN apk add postgresql-dev 6 | 7 | WORKDIR haskell-clean 8 | 9 | # install deps only 10 | COPY haskell-clean-architecture.cabal . 11 | RUN cabal v2-build --enable-executable-static --dependencies-only all 12 | 13 | # copy app's source files 14 | COPY app app/ 15 | COPY src src/ 16 | 17 | # build the app 18 | RUN cabal v2-build --enable-executable-static exe:haskell-clean-architecture-exe 19 | RUN cp ./dist-newstyle/build/x86_64-linux/ghc-8.10.4/haskell-clean-architecture-0.1.0.0/x/haskell-clean-architecture-exe/build/haskell-clean-architecture-exe/haskell-clean-architecture-exe ./app-exe 20 | 21 | FROM gcr.io/distroless/base:nonroot 22 | USER nonroot 23 | COPY --from=build-env --chown=nonroot:nonroot /haskell-clean/app-exe ./app 24 | ENTRYPOINT ["./app"] 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | 635 | Copyright (C) 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | Copyright (C) 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | build: 2 | hpack 3 | cabal build exe:haskell-clean-architecture-exe 4 | cp ./dist-newstyle/build/x86_64-linux/ghc-8.10.7/haskell-clean-architecture-0.1.0.0/x/haskell-clean-architecture-exe/build/haskell-clean-architecture-exe/haskell-clean-architecture-exe ./app-exe 5 | 6 | run: 7 | cabal run haskell-clean-architecture-exe 8 | 9 | build-docker: 10 | docker build -t haskell-clean-architecture . 11 | 12 | run-docker: build-docker start-pg 13 | docker run --rm -p 3000:3000 haskell-clean-architecture 14 | 15 | test: start-pg 16 | sleep 1 17 | cabal test --test-show-details=direct 18 | docker stop pg-test 19 | 20 | start-pg: 21 | docker stop pg-test || true 22 | docker run -d --rm -p 5432:5432 -e POSTGRES_PASSWORD=password --name=pg-test -v $(shell pwd)/scripts/pg.sql:/docker-entrypoint-initdb.d/init.sql postgres 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Simple Haskell](http://simplehaskell.org/badges/badge.svg)](http://simplehaskell.org) 2 | 3 | # Simple Haskell "Real world app" 4 | 5 | A "simple Haskell" web app in order to show how Haskell shines at building "standard" apps with industrial practices (tdd & bdd). 6 | 7 | It aims to implement the [real world app](https://github.com/gothinkster/realworld) API 8 | 9 | ## Main 3rd party libraries 10 | Following the Port & Adapter architecture, the frameworks can be replaced with one another. To illustrate this, the app let you choose between 2 http servers and 2 storage backends at startup (see below), they also pass the same test suite. 11 | 12 | - HTTP routers : [Scotty](https://hackage.haskell.org/package/scotty) & [Servant](https://hackage.haskell.org/package/servant) 13 | - Persistence : [Hasql](https://hackage.haskell.org/package/hasql) & Tvar (business logic tests) 14 | - Logs : [Katip](https://hackage.haskell.org/package/katip) & Tvar (business logic tests) 15 | - Testing : [Hspec](https://hackage.haskell.org/package/hspec) 16 | 17 | ## start the App 18 | 19 | open a shell with all the needed deps (using nix-shell) 20 | ``` 21 | nix-shell 22 | ``` 23 | 24 | ``` 25 | make start-pg 26 | make run 27 | ``` 28 | 29 | or the using docker (requires no local system dependency) 30 | ``` 31 | make run-docker 32 | ``` 33 | 34 | ## app configuration 35 | 36 | | var | default | type | description | 37 | |---|---|---|---| 38 | | SERVER | `servant` | `servant \| scotty` | the http server implementation | 39 | | PORT | `3000` | Int | the port the server will listen on | 40 | | STORAGE | `hasql` | `hasql\|inMem` | the storage implementation | 41 | | DB_HOST | `localhost` | String | (hasql): the db host | 42 | | DB_PORT | `5432` | Int | (hasql): the db port | 43 | | DB_USER | `postgres` | String | (hasql): the db user | 44 | | DB_PASSWORD | `password` | String | (hasql): the db password | 45 | | DB_NAME | `postgres` | String | (hasql): the db name | 46 | 47 | 48 | ``` 49 | curl -v localhost:3000/api/users -d '{"user": {"email": "bla", "username": "bob", "password": "hello"}}' -H 'content-type:application/json' 50 | ``` 51 | 52 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module Main where 4 | 5 | import qualified Adapter.EmailChecker as EmailChecker 6 | import qualified Adapter.Fake.Hasher as FakeHasher 7 | import qualified Adapter.Http.Lib as SharedHttp (Router) 8 | import qualified Adapter.Http.Scotty.Router as ScottyRouter 9 | import qualified Adapter.Http.Servant.Router as ServantRouter 10 | import qualified Adapter.Logger as KatipLogger 11 | import qualified Adapter.Storage.Hasql.User as HasqlUserRepo 12 | import qualified Adapter.Storage.InMem.User as InMemUserRepo 13 | import qualified Adapter.UUIDGen as UUIDGen 14 | import qualified Config.Config as Config 15 | import qualified Hasql.Connection as Connection 16 | import qualified Network.Wai 17 | import qualified Network.Wai.Handler.Warp as Warp 18 | import RIO 19 | import qualified RIO.Text as T 20 | import System.IO 21 | import qualified Usecase.Interactor as UC 22 | import qualified Usecase.LogicHandler as UC 23 | import qualified Usecase.UserLogin as UC 24 | import qualified Usecase.UserRegistration as UC 25 | 26 | main :: IO () 27 | main = do 28 | putStrLn "== Haskell Clean Architecture ==" 29 | 30 | -- we pick the HTTP server implementation (scotty or servant) and the port it'll listen on 31 | serverInstance <- Config.getStringFromEnv "SERVER" "servant" 32 | port <- Config.getIntFromEnv "PORT" 3000 33 | putStrLn $ "starting " ++ serverInstance ++ " server on port " ++ show port 34 | 35 | -- we pick the storage backend (hasql or inMem) 36 | storageBackend <- Config.getStringFromEnv "STORAGE" "hasql" 37 | putStrLn $ "using " ++ storageBackend ++ " as storage backend" 38 | 39 | router <- 40 | case storageBackend of 41 | "hasql" -> do 42 | connSettings <- hasqlConnectionSettings 43 | Right conn <- Connection.acquire connSettings 44 | buildRouter serverInstance (hasqlUserRepo conn) () 45 | _ -> do 46 | inMemStore <- newTVarIO $ InMemUserRepo.Store mempty 47 | buildRouter serverInstance inMemUserRepo inMemStore 48 | 49 | -- start the router 50 | Warp.run port router 51 | 52 | buildRouter :: UC.Logger (App a) => String -> UC.UserRepo (App a) -> a -> IO Network.Wai.Application 53 | buildRouter serverInstance a b = 54 | pickServer serverInstance (logicHandler a) $ runApp b 55 | where 56 | pickServer :: MonadThrow m => String -> SharedHttp.Router m 57 | pickServer serverInstance = 58 | case serverInstance of 59 | "scotty" -> ScottyRouter.start 60 | _ -> ServantRouter.start 61 | 62 | -- we partially apply the "adapters" functions to get the pure usecases (shared by both storage backends) 63 | logicHandler :: (Monad m, UC.Logger m, MonadUnliftIO m) => UC.UserRepo m -> UC.LogicHandler m 64 | logicHandler uRepo = 65 | UC.LogicHandler 66 | ( UC.register 67 | UUIDGen.genUUIDv4 68 | EmailChecker.checkEmailFormat 69 | (UC._getUserByEmail uRepo) 70 | (UC._getUserByName uRepo) 71 | (UC._insertUserPswd uRepo) 72 | ) 73 | ( UC.login 74 | FakeHasher.hash 75 | (UC._getUserByEmailAndHashedPassword uRepo) 76 | ) 77 | 78 | newtype App a b = InMemApp (RIO a b) 79 | deriving (Applicative, Functor, Monad, MonadThrow, MonadUnliftIO, MonadReader a, MonadIO) 80 | 81 | runApp :: a -> App a b -> IO b 82 | runApp inMemStore (InMemApp app) = runRIO inMemStore app 83 | 84 | -- inMem app 85 | type InMemStore = TVar InMemUserRepo.Store 86 | 87 | inMemUserRepo :: InMemUserRepo.InMemory x m => UC.UserRepo m 88 | inMemUserRepo = 89 | UC.UserRepo 90 | InMemUserRepo.insertUserPswd 91 | InMemUserRepo.getUserByID 92 | InMemUserRepo.getUserByEmail 93 | InMemUserRepo.getUserByName 94 | InMemUserRepo.getUserByEmailAndHashedPassword 95 | 96 | -- hasql App 97 | hasqlUserRepo :: (UC.Logger m, MonadThrow m, MonadUnliftIO m) => Connection.Connection -> UC.UserRepo m 98 | hasqlUserRepo c = 99 | UC.UserRepo 100 | (HasqlUserRepo.insertUserPswd c) 101 | (HasqlUserRepo.getUserByID c) 102 | (HasqlUserRepo.getUserByEmail c) 103 | (HasqlUserRepo.getUserByName c) 104 | undefined 105 | 106 | hasqlConnectionSettings :: IO Connection.Settings 107 | hasqlConnectionSettings = do 108 | dbHost <- Config.getStringFromEnv "DB_HOST" "localhost" 109 | dbPort <- Config.getIntFromEnv "DB_PORT" 5432 110 | dbUser <- Config.getStringFromEnv "DB_USER" "postgres" 111 | dbPassword <- Config.getStringFromEnv "DB_PASSWORD" "password" 112 | dbName <- Config.getStringFromEnv "DB_NAME" "postgres" 113 | pure $ Connection.settings (bString dbHost) (fromIntegral dbPort) (bString dbUser) (bString dbPassword) (bString dbName) 114 | where 115 | bString = T.encodeUtf8 . T.pack 116 | 117 | -- logger instances 118 | instance UC.Logger (App a) where 119 | log = KatipLogger.log 120 | -------------------------------------------------------------------------------- /docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: '2' 2 | 3 | services: 4 | postgres: 5 | image: postgres:13.2-alpine 6 | environment: 7 | - POSTGRES_PASSWORD=password 8 | 9 | conduit: 10 | image: haskell-clean-architecture 11 | ports: 12 | - 3000:3000 13 | 14 | jaeger: 15 | image: jaegertracing/all-in-one:latest 16 | ports: 17 | - 16686:16686 18 | 19 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | - path: "src" 4 | component: "lib:haskell-clean-architecture" 5 | 6 | - path: "app/Main.hs" 7 | component: "haskell-clean-architecture:exe:haskell-clean-architecture-exe" 8 | 9 | - path: "app/Paths_haskell_clean_architecture.hs" 10 | component: "haskell-clean-architecture:exe:haskell-clean-architecture-exe" 11 | 12 | - path: "test" 13 | component: "haskell-clean-architecture:test:haskell-clean-architecture-test" 14 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: haskell-clean-architecture 2 | version: 0.1.0.0 3 | github: "err0r500/haskell-clean-arch-realworld-app" 4 | license: GPL-3 5 | author: "err0r500" 6 | description: Please see the README on GitHub at 7 | 8 | dependencies: 9 | - base 10 | - rio 11 | - data-has 12 | 13 | # the logger 14 | - katip 15 | 16 | # the http servers 17 | - scotty 18 | - servant-server 19 | 20 | - wai 21 | - wai-extra 22 | - warp 23 | - http-types 24 | - mtl 25 | - aeson 26 | 27 | # storage 28 | - hasql 29 | - hasql-th 30 | - postgresql-error-codes 31 | 32 | # various utilities 33 | - uuid 34 | - email-validate 35 | 36 | default-extensions: 37 | - NoImplicitPrelude 38 | - OverloadedStrings 39 | - ConstraintKinds 40 | - FlexibleContexts 41 | - GeneralizedNewtypeDeriving 42 | - Rank2Types 43 | - MonoLocalBinds 44 | 45 | library: 46 | source-dirs: src 47 | ghc-options: 48 | - -Wall 49 | - -Wcompat 50 | - -Widentities 51 | - -Wincomplete-record-updates 52 | - -Wincomplete-uni-patterns 53 | - -Wpartial-fields 54 | 55 | executables: 56 | haskell-clean-architecture-exe: 57 | main: Main.hs 58 | source-dirs: app 59 | ghc-options: 60 | - -threaded 61 | - -rtsopts 62 | - -with-rtsopts=-N 63 | dependencies: 64 | - haskell-clean-architecture 65 | 66 | tests: 67 | haskell-clean-architecture-test: 68 | main: Spec.hs 69 | source-dirs: test 70 | ghc-options: 71 | - -threaded 72 | - -rtsopts 73 | - -with-rtsopts=-N 74 | dependencies: 75 | - hspec-discover 76 | - hspec 77 | - hspec-wai 78 | - hspec-wai-json 79 | - testcontainers 80 | - haskell-clean-architecture 81 | - directory 82 | - text 83 | - hasql 84 | - hasql-th 85 | -------------------------------------------------------------------------------- /scripts/pg.sql: -------------------------------------------------------------------------------- 1 | DROP TABLE IF EXISTS public.users; 2 | DROP SEQUENCE IF EXISTS public.users_id_seq; 3 | 4 | CREATE SEQUENCE public.users_id_seq; 5 | 6 | CREATE TABLE public.users ( 7 | uid UUID NOT NULL UNIQUE, 8 | name VARCHAR(150) NOT NULL UNIQUE CHECK (name <> ''), 9 | email VARCHAR(128) NOT NULL UNIQUE CHECK (email <> ''), 10 | password VARCHAR(250) NOT NULL 11 | ); 12 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let 2 | stable = import 3 | (builtins.fetchTarball { 4 | name = "nixos-21.11"; 5 | url = "https://github.com/NixOS/nixpkgs/archive/21.11.tar.gz"; 6 | sha256 = "162dywda2dvfj1248afxc45kcrg83appjd0nmdb541hl7rnncf02"; 7 | }) 8 | { }; 9 | in 10 | stable.mkShell { 11 | buildInputs = 12 | [ 13 | stable.cabal-install 14 | stable.hpack 15 | (stable.haskell.packages.ghc8107.ghcWithPackages (p: [ 16 | p.zlib 17 | p.postgresql-libpq 18 | ])) 19 | 20 | stable.haskell-language-server 21 | stable.haskellPackages.hspec-discover 22 | stable.haskellPackages.ormolu 23 | 24 | stable.libdeflate 25 | stable.fzf 26 | stable.zlib.dev 27 | stable.zlib-ng 28 | stable.libpqxx 29 | stable.postgresql 30 | ]; 31 | } 32 | 33 | -------------------------------------------------------------------------------- /src/Adapter/EmailChecker.hs: -------------------------------------------------------------------------------- 1 | module Adapter.EmailChecker where 2 | 3 | import qualified Domain.User as D 4 | import RIO 5 | import qualified Text.Email.Validate as Validate 6 | 7 | checkEmailFormat :: Monad m => D.Email -> m (Maybe ()) 8 | checkEmailFormat (D.Email email) = 9 | if Validate.isValid $ encodeUtf8 email then pure Nothing else pure $ Just () 10 | -------------------------------------------------------------------------------- /src/Adapter/Fake/Hasher.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Fake.Hasher where 2 | 3 | import RIO 4 | import qualified RIO.Text as T 5 | 6 | hash :: (Monad m) => Text -> m Text 7 | hash text = pure $ T.pack $ "hashed" ++ show text 8 | -------------------------------------------------------------------------------- /src/Adapter/Fake/Logger.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Fake.Logger where 2 | 3 | import qualified Adapter.Logger as Adapter 4 | import qualified Data.Has as DH 5 | import RIO 6 | 7 | type Logs = [Text] 8 | 9 | type Logger r m = (MonadReader r m, MonadIO m, DH.Has (TVar Logs) r) 10 | 11 | log :: (Logger r m, Adapter.Loggable a) => [a] -> m () 12 | log elemsToLog = do 13 | tvar <- asks DH.getter 14 | atomically $ do 15 | state <- readTVar tvar 16 | writeTVar tvar $ state ++ map Adapter.show' elemsToLog 17 | 18 | getLogs :: Logger r m => m Logs 19 | getLogs = do 20 | tvar <- asks DH.getter 21 | readTVarIO tvar 22 | -------------------------------------------------------------------------------- /src/Adapter/Fake/UUID.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Fake.UUID where 2 | 3 | import qualified Data.UUID as UUID 4 | import RIO 5 | 6 | newtype UUIDGen = UUIDGen 7 | { _uuid :: UUID.UUID 8 | } 9 | 10 | genUUID :: Monad m => UUID.UUID -> m UUID.UUID 11 | genUUID = pure 12 | -------------------------------------------------------------------------------- /src/Adapter/Http/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE RankNTypes #-} 3 | 4 | module Adapter.Http.Lib where 5 | 6 | import Data.Aeson 7 | import Data.List (stripPrefix) 8 | import qualified Domain.User as D 9 | import qualified Network.Wai as Wai 10 | import RIO 11 | import qualified Usecase.Interactor as UC 12 | import qualified Usecase.LogicHandler as UC 13 | 14 | -- the shared Router type 15 | type Router m = 16 | (MonadUnliftIO m, UC.Logger m) => 17 | UC.LogicHandler m -> 18 | (forall a. m a -> IO a) -> 19 | IO Wai.Application 20 | 21 | -- User (wrapper) 22 | newtype User a = User a 23 | deriving (Eq, Show, Generic) 24 | 25 | instance ToJSON a => ToJSON (User a) where 26 | toJSON (User a) = object ["user" .= a] 27 | 28 | instance FromJSON a => FromJSON (User a) where 29 | parseJSON (Object o) = User <$> o .: "user" 30 | parseJSON _ = fail "user must be an object" 31 | 32 | -- UserDetails 33 | data UserDetails = UserDetails 34 | { user_username :: D.Name, 35 | user_email :: D.Email 36 | } 37 | deriving (Eq, Show, Generic) 38 | 39 | instance FromJSON UserDetails where 40 | parseJSON = genericParseJSON $ stripping "user_" 41 | 42 | instance ToJSON UserDetails where 43 | toJSON = genericToJSON $ stripping "user_" 44 | 45 | fromDomain :: D.User -> UserDetails 46 | fromDomain user = UserDetails (D._name user) (D._email user) 47 | 48 | -- RegisterDetails 49 | data RegisterDetails = RegisterDetails 50 | { register_email :: D.Email, 51 | register_username :: D.Name, 52 | register_password :: D.Password 53 | } 54 | deriving (Eq, Show, Generic) 55 | 56 | instance FromJSON RegisterDetails where 57 | parseJSON = genericParseJSON $ stripping "register_" 58 | 59 | instance ToJSON RegisterDetails where 60 | toJSON = genericToJSON $ stripping "register_" 61 | 62 | -- LoginDetails 63 | data LoginDetails = LoginDetails 64 | { login_email :: D.Email, 65 | login_password :: D.Password 66 | } 67 | deriving (Eq, Show, Generic) 68 | 69 | instance FromJSON LoginDetails where 70 | parseJSON = genericParseJSON $ stripping "login_" 71 | 72 | instance ToJSON LoginDetails where 73 | toJSON = genericToJSON $ stripping "register_" 74 | 75 | -- helper 76 | -- removes the given prefix from field names 77 | stripping :: String -> Options 78 | stripping str = defaultOptions {fieldLabelModifier = strip str} 79 | where 80 | strip pref s = fromMaybe "" (stripPrefix pref s) 81 | -------------------------------------------------------------------------------- /src/Adapter/Http/Scotty/LoginUser.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Http.Scotty.LoginUser where 2 | 3 | import Adapter.Http.Lib as Lib 4 | import qualified Domain.User as D 5 | import Network.HTTP.Types 6 | ( status404, 7 | status500, 8 | ) 9 | import RIO 10 | import Usecase.UserLogin as UC 11 | import qualified Web.Scotty.Trans as ScottyT 12 | 13 | loginUser :: MonadIO m => UC.Login m -> ScottyT.ActionT LText m () 14 | loginUser uc = do 15 | (Lib.User body) <- ScottyT.jsonData 16 | resp <- lift $ uc $ D.LoginDetails (Lib.login_email body) (Lib.login_password body) 17 | case resp of 18 | Left UC.UserNotFound -> ScottyT.status status404 19 | Left UC.ErrTech -> ScottyT.status status500 20 | Right user -> ScottyT.json $ Lib.User $ Lib.fromDomain user 21 | -------------------------------------------------------------------------------- /src/Adapter/Http/Scotty/RegisterUser.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Http.Scotty.RegisterUser where 2 | 3 | import Adapter.Http.Lib as Lib 4 | import Network.HTTP.Types 5 | ( status422, 6 | status500, 7 | ) 8 | import RIO 9 | import RIO.Text.Lazy 10 | import Usecase.UserRegistration as UC 11 | import qualified Web.Scotty.Trans as ScottyT 12 | 13 | registerUser :: MonadIO m => UC.Register m -> ScottyT.ActionT LText m () 14 | registerUser uc = do 15 | (Lib.User b) <- ScottyT.jsonData 16 | resp <- 17 | lift $ 18 | uc (Lib.register_username b) (Lib.register_email b) (Lib.register_password b) 19 | case resp of 20 | Left (UC.ErrValidation _) -> ScottyT.status status422 21 | Left UC.ErrTechnical -> ScottyT.status status500 22 | Right uuid -> ScottyT.html $ fromStrict uuid 23 | -------------------------------------------------------------------------------- /src/Adapter/Http/Scotty/Router.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Http.Scotty.Router where 2 | 3 | import qualified Adapter.Http.Lib as Lib 4 | import Adapter.Http.Scotty.LoginUser 5 | import Adapter.Http.Scotty.RegisterUser 6 | import qualified Network.HTTP.Types as HttpTypes 7 | import RIO 8 | import qualified Usecase.Interactor as UC 9 | import qualified Usecase.LogicHandler as UC 10 | import qualified Web.Scotty.Trans as ScottyT 11 | 12 | start :: (MonadThrow m, MonadIO m, UC.Logger m) => Lib.Router m 13 | start logicHandler runner = 14 | ScottyT.scottyAppT 15 | runner 16 | ( do 17 | ScottyT.get "/" $ ScottyT.status HttpTypes.status200 -- health check 18 | ScottyT.post "/api/users" $ registerUser $ UC._userRegister logicHandler 19 | ScottyT.post "/api/users/login" $ loginUser $ UC._userLogin logicHandler 20 | ScottyT.notFound $ ScottyT.status HttpTypes.status404 21 | ) 22 | -------------------------------------------------------------------------------- /src/Adapter/Http/Servant/LoginUser.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Http.Servant.LoginUser where 2 | 3 | import qualified Adapter.Http.Lib as Lib 4 | import qualified Domain.User as D 5 | import RIO 6 | import Servant (err404) 7 | import qualified Usecase.Interactor as UC 8 | import qualified Usecase.UserLogin as UC 9 | ( Login, 10 | ) 11 | 12 | loginUser :: 13 | (MonadThrow m, MonadIO m, UC.Logger m) => 14 | UC.Login m -> 15 | Lib.LoginDetails -> 16 | m (Lib.User Lib.UserDetails) 17 | loginUser uc (Lib.LoginDetails email password) = do 18 | resp <- uc (D.LoginDetails email password) 19 | case resp of 20 | Left _ -> throwM err404 21 | Right user -> pure $ Lib.User $ Lib.fromDomain user 22 | -------------------------------------------------------------------------------- /src/Adapter/Http/Servant/RegisterUser.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Http.Servant.RegisterUser where 2 | 3 | import qualified Adapter.Http.Lib as Lib 4 | import qualified Debug.Trace as Debug 5 | import RIO 6 | import Servant (err422, err500) 7 | import qualified Usecase.Interactor as UC 8 | import qualified Usecase.UserRegistration as UC 9 | 10 | registerUser :: (MonadThrow m, MonadIO m, UC.Logger m) => UC.Register m -> Lib.RegisterDetails -> m Text 11 | registerUser uc (Lib.RegisterDetails email name password) = do 12 | resp <- Debug.trace "http:" uc name email password 13 | case resp of 14 | Left (UC.ErrValidation ee) -> 15 | let _ = Debug.trace "x" ee 16 | in throwM err422 17 | Left UC.ErrTechnical -> throwM err500 18 | Right uuid -> pure uuid 19 | -------------------------------------------------------------------------------- /src/Adapter/Http/Servant/Router.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | 4 | module Adapter.Http.Servant.Router where 5 | 6 | import qualified Adapter.Http.Lib as Lib 7 | import qualified Adapter.Http.Servant.LoginUser as Handler 8 | import qualified Adapter.Http.Servant.RegisterUser as Handler 9 | import qualified Control.Monad.Except as Except 10 | import RIO hiding (Handler) 11 | import Servant 12 | import qualified Usecase.Interactor as UC 13 | import qualified Usecase.LogicHandler as UC 14 | 15 | start :: (MonadIO m, UC.Logger m, MonadThrow m) => Lib.Router m 16 | start logicHandler runner = 17 | pure $ 18 | serve (Proxy :: Proxy API) $ 19 | hoistServer 20 | (Proxy :: Proxy API) 21 | (ioToHandler . runner) 22 | (server logicHandler) 23 | 24 | type API = 25 | Get '[JSON] NoContent -- health check 26 | :<|> "api" :> "users" :> ReqBody '[JSON] (Lib.User Lib.RegisterDetails) :> Post '[PlainText] Text -- register new user 27 | :<|> "api" :> "users" :> "login" :> ReqBody '[JSON] (Lib.User Lib.LoginDetails) :> Post '[JSON] (Lib.User Lib.UserDetails) -- user login 28 | 29 | server :: 30 | (MonadThrow m, MonadUnliftIO m, MonadIO m, UC.Logger m) => UC.LogicHandler m -> ServerT API m 31 | server logicHandler = healthH :<|> regUser :<|> loginUser 32 | where 33 | healthH = pure NoContent 34 | regUser (Lib.User body) = Handler.registerUser (UC._userRegister logicHandler) body 35 | loginUser (Lib.User body) = Handler.loginUser (UC._userLogin logicHandler) body 36 | 37 | -- liftIO is not enough to catch the "throwM"s in handlers so we rebuild the handler manually 38 | ioToHandler :: IO a -> Handler a 39 | ioToHandler = Handler . Except.ExceptT . try 40 | -------------------------------------------------------------------------------- /src/Adapter/Logger.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE IncoherentInstances #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | module Adapter.Logger where 8 | 9 | import Control.Exception 10 | import qualified Domain.Messages as D 11 | import Katip 12 | import RIO 13 | 14 | class Show a => Loggable a where 15 | type F a 16 | log' :: a -> F (IO ()) 17 | show' :: a -> Text 18 | 19 | instance Show a => Loggable a where 20 | type F a = KatipContextT IO () 21 | log' mess = $(logTM) ErrorS (showLS mess) 22 | show' = tshow 23 | 24 | instance Show a => Loggable (D.Message a) where 25 | type F (D.Message a) = KatipContextT IO () 26 | log' (D.ErrorMsg mess) = $(logTM) ErrorS (showLS $ show mess) 27 | log' (D.WarningMsg mess) = $(logTM) WarningS (showLS $ show mess) 28 | log' (D.InfoMsg mess) = $(logTM) InfoS (showLS $ show mess) 29 | log' (D.DebugMsg mess) = $(logTM) DebugS (showLS $ show mess) 30 | show' = tshow 31 | 32 | log :: (MonadIO m, Loggable a) => [a] -> m () 33 | log elemsToLog = do 34 | handleScribe <- liftIO $ mkHandleScribe ColorIfTerminal stdout (permitItem DebugS) V2 35 | let mkLogEnv = 36 | registerScribe "stdout" handleScribe defaultScribeSettings 37 | =<< initLogEnv "MyApp" "production" 38 | liftIO $ 39 | Control.Exception.bracket mkLogEnv closeScribes $ \le -> 40 | runKatipContextT le () mempty $ mapM_ log' elemsToLog 41 | -------------------------------------------------------------------------------- /src/Adapter/Storage/Hasql/User.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Adapter.Storage.Hasql.User where 5 | 6 | import qualified Data.UUID as UUID 7 | import qualified Domain.Messages as D 8 | import qualified Domain.User as D 9 | import qualified Hasql.Connection as HConn 10 | import qualified Hasql.Session as Session 11 | import Hasql.Statement (Statement) 12 | import qualified Hasql.TH as TH 13 | import qualified PostgreSQL.ErrorCodes as PgErr 14 | import RIO hiding (trace) 15 | import qualified Usecase.Interactor as UC 16 | 17 | execQuery :: MonadIO m => HConn.Connection -> a -> Statement a b -> m (Either Session.QueryError b) 18 | execQuery conn param stmt = liftIO $ Session.run (Session.statement param stmt) conn 19 | 20 | insertUserPswd :: (MonadIO m, UC.Logger m) => HConn.Connection -> UC.InsertUserPswd m 21 | insertUserPswd conn user password = do 22 | result <- execQuery conn (getQueryFields user password) insertUserStmt 23 | case result of 24 | Right _ -> pure Nothing 25 | Left (Session.QueryError _ _ (Session.ResultError (Session.ServerError code e _ _))) -> 26 | if code == PgErr.unique_violation 27 | then do 28 | UC.log [D.ErrorMsg e] 29 | pure $ Just (UC.SpecificErr UC.InsertUserConflict) 30 | else handleErr e 31 | Left e -> handleErr e 32 | where 33 | getQueryFields :: D.User -> D.Password -> (UUID.UUID, Text, Text, Text) 34 | getQueryFields (D.User uid' (D.Name name') (D.Email email')) (D.Password password') = (uid', name', email', password') 35 | insertUserStmt = 36 | [TH.rowsAffectedStatement| 37 | insert into "users" (uid, name, email, password) 38 | values ($1::uuid, $2::text, $3::text, $4::text) 39 | |] 40 | handleErr e = do 41 | UC.log [D.ErrorMsg e] 42 | pure $ Just UC.AnyErr 43 | 44 | getUserByID :: (MonadIO m, UC.Logger m) => HConn.Connection -> UC.GetUserByID m 45 | getUserByID c id' = sharedGetUserBy c id' userByIDStmt 46 | where 47 | userByIDStmt = 48 | [TH.maybeStatement| 49 | select uid :: uuid, name :: text, email :: text 50 | from users 51 | where uid = $1 :: uuid 52 | |] 53 | 54 | getUserByEmail :: (MonadIO m, UC.Logger m) => HConn.Connection -> UC.GetUserByEmail m 55 | getUserByEmail c (D.Email email') = sharedGetUserBy c email' userByEmailStmt 56 | where 57 | userByEmailStmt = 58 | [TH.maybeStatement| 59 | select uid :: uuid, name :: text, email :: text 60 | from users 61 | where email = $1 :: text 62 | |] 63 | 64 | getUserByName :: (MonadIO m, UC.Logger m) => HConn.Connection -> UC.GetUserByName m 65 | getUserByName c (D.Name name') = sharedGetUserBy c name' userByNameStmt 66 | where 67 | userByNameStmt = 68 | [TH.maybeStatement| 69 | select uid :: uuid, name :: text, email :: text 70 | from users 71 | where name = $1 :: text 72 | |] 73 | 74 | sharedGetUserBy :: 75 | (MonadIO m, UC.Logger m) => 76 | HConn.Connection -> 77 | a -> 78 | Statement a (Maybe (UUID.UUID, Text, Text)) -> 79 | m (Either UC.TechErrOnly (Maybe D.User)) 80 | sharedGetUserBy conn param stmt = do 81 | result <- execQuery conn param stmt 82 | case result of 83 | Right (Just (uuid, name, email)) -> 84 | pure $ Right . Just $ D.User uuid (D.Name name) (D.Email email) 85 | Right Nothing -> pure $ Right Nothing 86 | Left err -> do 87 | UC.log [D.ErrorMsg err] 88 | pure $ Left UC.AnyErr 89 | -------------------------------------------------------------------------------- /src/Adapter/Storage/InMem/User.hs: -------------------------------------------------------------------------------- 1 | module Adapter.Storage.InMem.User where 2 | 3 | import qualified Data.Has as DH 4 | import qualified Data.UUID as UUID 5 | import qualified Domain.User as D 6 | import RIO 7 | import qualified RIO.Map as Map 8 | import qualified Usecase.Interactor as UC 9 | 10 | type InMemory r m = (DH.Has (TVar Store) r, MonadReader r m, MonadIO m) 11 | 12 | data User = User 13 | { _id :: !UUID.UUID, 14 | _name :: !Text, 15 | _email :: !Text, 16 | _password :: !Text 17 | } 18 | deriving (Show, Eq) 19 | 20 | newtype Store = Store 21 | { users :: Map UUID.UUID User 22 | } 23 | 24 | fromDomain :: D.User -> User 25 | fromDomain (D.User id' (D.Name name) (D.Email email)) = User id' name email "" -- (D._id d) (D._name d) (D.unEmail $ D._email d) "" 26 | 27 | toDomain :: User -> D.User 28 | toDomain u = D.User (_id u) (D.Name $ _name u) (D.Email $ _email u) 29 | 30 | insertUserPswd :: InMemory r m => UC.InsertUserPswd m 31 | insertUserPswd (D.User uid' (D.Name name') (D.Email email')) (D.Password password') = do 32 | tvar <- asks DH.getter 33 | atomically $ do 34 | state <- readTVar tvar 35 | writeTVar 36 | tvar 37 | state {users = Map.insert uid' (User uid' name' email' password') $ users state} 38 | pure Nothing 39 | 40 | getUserByID :: InMemory r m => UC.GetUserByID m 41 | getUserByID userID = do 42 | tvar <- asks DH.getter 43 | atomically $ do 44 | state <- readTVar tvar 45 | pure $ Right $ toDomain <$> Map.lookup userID (users state) 46 | 47 | getUserByEmail :: InMemory r m => UC.GetUserByEmail m 48 | getUserByEmail (D.Email email') = commonSearch (\u -> email' == _email u) 49 | 50 | getUserByName :: InMemory r m => UC.GetUserByName m 51 | getUserByName (D.Name name') = commonSearch (\u -> name' == _name u) 52 | 53 | getUserByEmailAndHashedPassword :: InMemory r m => UC.GetUserByEmailAndHashedPassword m 54 | getUserByEmailAndHashedPassword (D.Email email') (D.Password pass') = 55 | commonSearch (\u -> email' == _email u && pass' == _password u) 56 | 57 | commonSearch :: InMemory r m => (User -> Bool) -> m (Either (UC.Err Void) (Maybe D.User)) 58 | commonSearch filter_ = do 59 | tvar <- asks DH.getter 60 | atomically $ do 61 | state <- readTVar tvar 62 | case filter filter_ $ map snd $ Map.toList (users state) of 63 | [] -> pure $ Right Nothing 64 | (x : _) -> pure $ Right (Just (toDomain x)) 65 | -------------------------------------------------------------------------------- /src/Adapter/UUIDGen.hs: -------------------------------------------------------------------------------- 1 | module Adapter.UUIDGen where 2 | 3 | import qualified Data.UUID as UUID 4 | import qualified Data.UUID.V4 as UUID 5 | import RIO 6 | 7 | genUUIDv4 :: MonadIO m => m UUID.UUID 8 | genUUIDv4 = liftIO UUID.nextRandom 9 | -------------------------------------------------------------------------------- /src/Config/Config.hs: -------------------------------------------------------------------------------- 1 | module Config.Config 2 | ( getIntFromEnv, 3 | getStringFromEnv, 4 | ) 5 | where 6 | 7 | import RIO 8 | import System.Environment 9 | import qualified System.IO.Error as IOError 10 | 11 | getIntFromEnv :: String -> Int -> IO Int 12 | getIntFromEnv key defaultValue = do 13 | result <- IOError.tryIOError $ getEnv key 14 | case result of 15 | Left _ -> pure defaultValue 16 | Right fromEnv -> case readMaybe fromEnv :: Maybe Int of 17 | Just x -> pure x 18 | Nothing -> pure defaultValue 19 | 20 | getStringFromEnv :: String -> String -> IO String 21 | getStringFromEnv key defaultValue = do 22 | result <- IOError.tryIOError $ getEnv key 23 | case result of 24 | Left _ -> pure defaultValue 25 | Right fromEnv -> pure fromEnv 26 | -------------------------------------------------------------------------------- /src/Domain/Messages.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | module Domain.Messages where 4 | 5 | import RIO 6 | 7 | data Message a where 8 | ErrorMsg :: Show a => a -> Message a 9 | WarningMsg :: Show a => a -> Message a 10 | InfoMsg :: Show a => a -> Message a 11 | DebugMsg :: Show a => a -> Message a 12 | 13 | instance Show (Message a) where 14 | show (ErrorMsg a) = show a 15 | show (WarningMsg a) = show a 16 | show (InfoMsg a) = show a 17 | show (DebugMsg a) = show a 18 | -------------------------------------------------------------------------------- /src/Domain/User.hs: -------------------------------------------------------------------------------- 1 | module Domain.User where 2 | 3 | import Data.Aeson 4 | import qualified Data.UUID as UUID 5 | import RIO 6 | 7 | newtype Email = Email {unEmail :: Text} 8 | deriving (Show, Eq, Semigroup, FromJSON, ToJSON) 9 | 10 | newtype Name = Name {unName :: Text} 11 | deriving (Show, Eq, FromJSON, ToJSON) 12 | 13 | newtype Password = Password {unPassword :: Text} 14 | deriving (Show, Eq, Semigroup, FromJSON, ToJSON) 15 | 16 | data User = User 17 | { _id :: !UUID.UUID, 18 | _name :: !Name, 19 | _email :: !Email 20 | } 21 | deriving (Show, Eq) 22 | 23 | data LoginDetails = LoginDetails 24 | { _loginEmail :: !Email, 25 | _loginPassword :: !Password 26 | } 27 | -------------------------------------------------------------------------------- /src/Usecase/Interactor.hs: -------------------------------------------------------------------------------- 1 | module Usecase.Interactor where 2 | 3 | import qualified Adapter.Logger as Logger 4 | import qualified Data.UUID as UUID 5 | import qualified Domain.User as D 6 | import RIO 7 | 8 | -- UserRepo 9 | data UserRepo m = UserRepo 10 | { _insertUserPswd :: InsertUserPswd m, 11 | _getUserByID :: GetUserByID m, 12 | _getUserByEmail :: GetUserByEmail m, 13 | _getUserByName :: GetUserByName m, 14 | _getUserByEmailAndHashedPassword :: GetUserByEmailAndHashedPassword m 15 | } 16 | 17 | data Err a 18 | = AnyErr -- if it's a tech error we don't want more details at this level, it has to be handled "below", won't be logged here neither 19 | | SpecificErr a -- usecase want to know about theses errors when they happen 20 | deriving (Show, Eq) 21 | 22 | type TechErrOnly = Err Void 23 | 24 | data ErrInsertUser = InsertUserConflict 25 | deriving (Show, Eq) 26 | 27 | type InsertUserPswd m = Monad m => D.User -> D.Password -> m (Maybe (Err ErrInsertUser)) 28 | 29 | -- Err Void is obviously impossible to construct, the single constructor is then AnyErr 30 | -- the idea is to make explicit the fact we don't care specially about some specific things 31 | -- that may go wrong (contrary to the `Err ErrInsertUser` above, for example). 32 | type GetUserByID m = Monad m => UUID.UUID -> m (Either (Err Void) (Maybe D.User)) 33 | 34 | type GetUserByEmail m = Monad m => D.Email -> m (Either (Err Void) (Maybe D.User)) 35 | 36 | type GetUserByName m = Monad m => D.Name -> m (Either (Err Void) (Maybe D.User)) 37 | 38 | type GetUserByEmailAndHashedPassword m = 39 | Monad m => D.Email -> D.Password -> m (Either (Err Void) (Maybe D.User)) 40 | 41 | -- Mail utilies 42 | type CheckEmailFormat m = Monad m => D.Email -> m (Maybe ()) 43 | 44 | -- UUID generation 45 | type GenUUID m = Monad m => m UUID.UUID 46 | 47 | -- Hasher 48 | type HashText m = Monad m => Text -> m Text 49 | 50 | -- Logger 51 | class Monad m => Logger m where 52 | log :: Logger.Loggable a => [a] -> m () 53 | -------------------------------------------------------------------------------- /src/Usecase/LogicHandler.hs: -------------------------------------------------------------------------------- 1 | module Usecase.LogicHandler where 2 | 3 | import qualified Usecase.UserLogin as UC 4 | import qualified Usecase.UserRegistration as UC 5 | 6 | data LogicHandler m = LogicHandler 7 | { _userRegister :: UC.Register m, 8 | _userLogin :: UC.Login m 9 | } 10 | -------------------------------------------------------------------------------- /src/Usecase/UserLogin.hs: -------------------------------------------------------------------------------- 1 | module Usecase.UserLogin where 2 | 3 | import qualified Domain.User as D 4 | import RIO 5 | import qualified Usecase.Interactor as UC 6 | 7 | data Err = ErrTech | UserNotFound deriving (Show, Eq) 8 | 9 | type Login m = Monad m => D.LoginDetails -> m (Either Err D.User) 10 | 11 | login :: UC.Logger m => UC.HashText m -> UC.GetUserByEmailAndHashedPassword m -> Login m 12 | login hash getUserByEmailAndHashedPassword loginDetails = do 13 | hashedPass <- hash $ D.unPassword $ D._loginPassword loginDetails 14 | foundUser <- getUserByEmailAndHashedPassword (D._loginEmail loginDetails) (D.Password hashedPass) 15 | case foundUser of 16 | Left err -> do 17 | UC.log [err] 18 | pure $ Left ErrTech 19 | Right (Just user) -> pure $ Right user 20 | Right Nothing -> pure $ Left UserNotFound 21 | -------------------------------------------------------------------------------- /src/Usecase/UserRegistration.hs: -------------------------------------------------------------------------------- 1 | module Usecase.UserRegistration 2 | ( register, 3 | Register, 4 | Err (..), 5 | ValidationErr (..), 6 | ) 7 | where 8 | 9 | import Control.Monad.Except 10 | import qualified Data.UUID as UUID 11 | import qualified Domain.User as D 12 | import RIO hiding (handle) 13 | import qualified Usecase.Interactor as UC 14 | 15 | -- PUBLIC 16 | -- the pure logic usecase signature 17 | type Register m = Monad m => D.Name -> D.Email -> D.Password -> m (Either Err Text) 18 | 19 | data Err 20 | = ErrTechnical 21 | | ErrValidation [ValidationErr] 22 | deriving (Show, Eq) 23 | 24 | data ValidationErr 25 | = EmailConflict 26 | | NameConflict 27 | | IdConflict 28 | | MalformedEmail 29 | deriving (Show, Eq) 30 | 31 | instance Semigroup Err where 32 | ErrTechnical <> _ = ErrTechnical 33 | _ <> ErrTechnical = ErrTechnical 34 | ErrValidation aa <> ErrValidation bb = ErrValidation (aa <> bb) 35 | 36 | instance Monoid Err where 37 | mempty = ErrValidation [] 38 | 39 | register :: 40 | Monad m => 41 | UC.GenUUID m -> 42 | UC.CheckEmailFormat m -> 43 | UC.GetUserByEmail m -> 44 | UC.GetUserByName m -> 45 | UC.InsertUserPswd m -> 46 | Register m 47 | register genUUID checkEmailFormat getUserByEmail getUserByName insertUserPswd name email pswd = 48 | runExceptT $ 49 | do 50 | _ <- ExceptT validateInputs 51 | uuid <- ExceptT $ Right <$> genUUID 52 | _ <- ExceptT $ storeUser uuid 53 | pure $ UUID.toText uuid 54 | where 55 | validateInputs = 56 | checkValidationErrs 57 | <$> filterJust 58 | [ handleMaybe MalformedEmail <$> checkEmailFormat email, 59 | handleEither EmailConflict <$> getUserByEmail email, 60 | handleEither NameConflict <$> getUserByName name 61 | ] 62 | 63 | storeUser uuid = handleInsertUser <$> insertUserPswd (D.User uuid name email) pswd 64 | where 65 | handleInsertUser Nothing = Right () 66 | handleInsertUser (Just _) = Left ErrTechnical 67 | 68 | -- PRIVATE 69 | handleMaybe :: ValidationErr -> Maybe a -> Maybe Err 70 | handleMaybe v may = case may of 71 | Nothing -> Nothing 72 | (Just _) -> Just $ ErrValidation [v] 73 | 74 | handleEither :: ValidationErr -> Either a (Maybe b) -> Maybe Err 75 | handleEither v e = case e of 76 | Right Nothing -> Nothing 77 | Right (Just _) -> Just (ErrValidation [v]) 78 | Left _ -> Just ErrTechnical 79 | 80 | filterJust :: Applicative f => [f (Maybe a)] -> f [a] 81 | filterJust mMay = catMaybes <$> sequenceA mMay 82 | 83 | checkValidationErrs :: Monoid a => [a] -> Either a () 84 | checkValidationErrs ee = 85 | if not (null ee) 86 | then Left $ mconcat ee 87 | else Right () 88 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: 2 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/24.yaml 3 | 4 | packages: 5 | - . 6 | 7 | extra-deps: 8 | - postgresql-error-codes-1.0.1@sha256:34ce40401dc21762996dadd38336436f40a09da95ad3309ba6dc506d707cff11,1413 9 | - hasql-th-0.4.0.8@sha256:e77af01c354fcebb0fc8358a4bb2f7b361329bce28f783d8d6b17fbd5fa43279,2245 10 | - postgresql-syntax-0.3.0.3@sha256:b93a73c388811e331327561d85ed268f232be6c7f8f90ff27b2091c64c6aea90,4170 11 | - fast-builder-0.1.2.1@sha256:6e3148d9ac21e5ec900fa59d1d65322e6b4c0491f19b53bdbe093186a519eb9f,2791 12 | - headed-megaparsec-0.2@sha256:53e0fca4b30bc568f0dfae5b97abe7967939c8a9ee00f30bc99936d75181dd72,1566 13 | - testcontainers-0.3.1.0@sha256:8f9c100652403b72a467eb005b1c936c7116e02938057bd5b6fd7cdc465b9532,2700 14 | 15 | #nix: 16 | # enable: true 17 | # packages: [pcre, postgresql] 18 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: 7 | - completed: 8 | hackage: postgresql-error-codes-1.0.1@sha256:34ce40401dc21762996dadd38336436f40a09da95ad3309ba6dc506d707cff11,1413 9 | pantry-tree: 10 | size: 240 11 | sha256: 2b8d529e883ae9ff4c1c98b05410edd6343b0ea2ec016bae256ff7d7ede3fc46 12 | original: 13 | hackage: postgresql-error-codes-1.0.1@sha256:34ce40401dc21762996dadd38336436f40a09da95ad3309ba6dc506d707cff11,1413 14 | - completed: 15 | hackage: hasql-th-0.4.0.8@sha256:e77af01c354fcebb0fc8358a4bb2f7b361329bce28f783d8d6b17fbd5fa43279,2245 16 | pantry-tree: 17 | size: 864 18 | sha256: d3975fb5fdfc16c22ae5296a1d720ffa4cfc3661117d7eba0ad1232e4be527d6 19 | original: 20 | hackage: hasql-th-0.4.0.8@sha256:e77af01c354fcebb0fc8358a4bb2f7b361329bce28f783d8d6b17fbd5fa43279,2245 21 | - completed: 22 | hackage: postgresql-syntax-0.3.0.3@sha256:b93a73c388811e331327561d85ed268f232be6c7f8f90ff27b2091c64c6aea90,4170 23 | pantry-tree: 24 | size: 1141 25 | sha256: 59f0edcb31c8b30432c1fef4107805cc9e20e7cc2e3d5e2f819789c556c6a386 26 | original: 27 | hackage: postgresql-syntax-0.3.0.3@sha256:b93a73c388811e331327561d85ed268f232be6c7f8f90ff27b2091c64c6aea90,4170 28 | - completed: 29 | hackage: fast-builder-0.1.2.1@sha256:6e3148d9ac21e5ec900fa59d1d65322e6b4c0491f19b53bdbe093186a519eb9f,2791 30 | pantry-tree: 31 | size: 986 32 | sha256: 6b1f7822bdc4b8905fd871929f5ecc5a337588f83d858079abce3b6393c6d1e4 33 | original: 34 | hackage: fast-builder-0.1.2.1@sha256:6e3148d9ac21e5ec900fa59d1d65322e6b4c0491f19b53bdbe093186a519eb9f,2791 35 | - completed: 36 | hackage: headed-megaparsec-0.2@sha256:53e0fca4b30bc568f0dfae5b97abe7967939c8a9ee00f30bc99936d75181dd72,1566 37 | pantry-tree: 38 | size: 383 39 | sha256: 4277a2ab79fd6da7cc4fb01c55426322dffe4a53cdf80ef66d033034dc43d109 40 | original: 41 | hackage: headed-megaparsec-0.2@sha256:53e0fca4b30bc568f0dfae5b97abe7967939c8a9ee00f30bc99936d75181dd72,1566 42 | - completed: 43 | hackage: testcontainers-0.3.1.0@sha256:8f9c100652403b72a467eb005b1c936c7116e02938057bd5b6fd7cdc465b9532,2700 44 | pantry-tree: 45 | size: 747 46 | sha256: 57d3891d7f17092873f0fd5a3b35590e479d7ad90ada7e566e01c8bac6decb69 47 | original: 48 | hackage: testcontainers-0.3.1.0@sha256:8f9c100652403b72a467eb005b1c936c7116e02938057bd5b6fd7cdc465b9532,2700 49 | snapshots: 50 | - completed: 51 | size: 587821 52 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/24.yaml 53 | sha256: 06d844ba51e49907bd29cb58b4a5f86ee7587a4cd7e6cf395eeec16cba619ce8 54 | original: 55 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/24.yaml 56 | -------------------------------------------------------------------------------- /test/Http/Lib.hs: -------------------------------------------------------------------------------- 1 | module Http.Lib where 2 | 3 | import qualified Adapter.Logger as Logger 4 | import qualified Network.Wai as Wai 5 | import RIO 6 | import qualified Usecase.Interactor as UC 7 | import qualified Usecase.LogicHandler as UC 8 | import qualified Usecase.UserRegistration as UC 9 | 10 | -- unit replaces State since we don't need any 11 | newtype App a = App (RIO () a) deriving (Applicative, Functor, Monad, MonadUnliftIO, MonadThrow, MonadIO) 12 | 13 | run :: App a -> IO a 14 | run (App app) = runRIO () app 15 | 16 | type StartRouter = UC.LogicHandler App -> IO Wai.Application 17 | 18 | emptyLogicH :: UC.LogicHandler App 19 | emptyLogicH = UC.LogicHandler {UC._userRegister = undefined, UC._userLogin = undefined} 20 | 21 | instance UC.Logger App where 22 | log = Logger.log 23 | -------------------------------------------------------------------------------- /test/Http/ScottySpec.hs: -------------------------------------------------------------------------------- 1 | module Http.ScottySpec where 2 | 3 | import qualified Adapter.Http.Scotty.Router as Scotty 4 | import qualified Http.Lib as Lib 5 | import qualified Http.Specs.Health as Health 6 | import qualified Http.Specs.LoginUser as LoginUser 7 | import qualified Http.Specs.RegisterUser as RegisterUser 8 | import RIO 9 | import Test.Hspec 10 | 11 | start :: Lib.StartRouter 12 | start app = Scotty.start app Lib.run 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "health" $ Health.spec start 17 | describe "register user" $ RegisterUser.spec start 18 | describe "login user" $ LoginUser.spec start 19 | -------------------------------------------------------------------------------- /test/Http/ServantSpec.hs: -------------------------------------------------------------------------------- 1 | module Http.ServantSpec where 2 | 3 | import qualified Adapter.Http.Servant.Router as Servant 4 | import qualified Http.Lib as Lib 5 | import qualified Http.Specs.Health as Health 6 | import qualified Http.Specs.LoginUser as LoginUser 7 | import qualified Http.Specs.RegisterUser as RegisterUser 8 | import RIO 9 | import Test.Hspec 10 | 11 | start :: Lib.StartRouter 12 | start app = Servant.start app Lib.run 13 | 14 | spec :: Spec 15 | spec = do 16 | describe "health" $ Health.spec start 17 | describe "register user" $ RegisterUser.spec start 18 | describe "login user" $ LoginUser.spec start 19 | -------------------------------------------------------------------------------- /test/Http/Specs/Health.hs: -------------------------------------------------------------------------------- 1 | module Http.Specs.Health where 2 | 3 | import qualified Http.Lib as Lib 4 | import RIO 5 | import Test.Hspec 6 | import Test.Hspec.Wai 7 | 8 | spec :: Lib.StartRouter -> Spec 9 | spec start = 10 | describe "health check" $ 11 | with (start undefined) $ 12 | it "responds with 200 without body" $ 13 | get "/" 14 | `shouldRespondWith` "" {matchStatus = 200} 15 | -------------------------------------------------------------------------------- /test/Http/Specs/LoginUser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module Http.Specs.LoginUser where 4 | 5 | import qualified Data.UUID as UUID 6 | import qualified Domain.User as D 7 | import qualified Http.Lib as Lib 8 | import qualified Http.Utils as Utils 9 | import RIO 10 | import Test.Hspec 11 | import Test.Hspec.Wai 12 | import Test.Hspec.Wai.JSON 13 | import qualified Usecase.LogicHandler as UC 14 | import qualified Usecase.UserLogin as UC 15 | ( Err (..), 16 | ) 17 | import Utils 18 | 19 | spec :: Lib.StartRouter -> Spec 20 | spec start = do 21 | let reqPath = "/api/users/login" 22 | user = D.User fakeUUID1 (D.Name "username") (D.Email "email@example.com") 23 | reqBody = 24 | [json| 25 | { 26 | "user": { 27 | "email": "matth@example.com", 28 | "password": "mypassword" 29 | } 30 | } 31 | |] 32 | respBody = 33 | [json| 34 | { 35 | "user": { 36 | "email": "email@example.com", 37 | "username": "username" 38 | } 39 | } 40 | |] 41 | 42 | describe "happy case" $ do 43 | let allGood = Lib.emptyLogicH {UC._userLogin = \_ -> pure $ Right user} 44 | with (start allGood) $ 45 | it "responds 200 with the user" $ 46 | Utils.postSimpleJSON reqPath reqBody 47 | `shouldRespondWith` respBody {matchStatus = 200} 48 | 49 | describe "email collision" $ do 50 | let coll = Lib.emptyLogicH {UC._userLogin = \_ -> pure $ Left UC.UserNotFound} 51 | with (start coll) $ 52 | it "responds with 404" $ 53 | Utils.postSimpleJSON reqPath reqBody 54 | `shouldRespondWith` "" {matchStatus = 404} 55 | -------------------------------------------------------------------------------- /test/Http/Specs/RegisterUser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | module Http.Specs.RegisterUser where 4 | 5 | import qualified Domain.User as D 6 | import qualified Http.Lib as Lib 7 | import qualified Http.Utils as Utils 8 | import RIO 9 | import Test.Hspec 10 | import Test.Hspec.Wai 11 | import Test.Hspec.Wai.JSON 12 | import qualified Usecase.LogicHandler as UC 13 | import qualified Usecase.UserRegistration as UC 14 | 15 | spec :: Lib.StartRouter -> Spec 16 | spec start = do 17 | let reqPath = "/api/users" 18 | reqBody = 19 | [json| 20 | { 21 | "user": { 22 | "username": "u", 23 | "email": "e", 24 | "password": "p" 25 | } 26 | } 27 | |] 28 | 29 | describe "happycase" $ do 30 | let allGood = Lib.emptyLogicH {UC._userRegister = \_ _ _ -> pure $ Right "myResp"} 31 | with (start allGood) $ 32 | it "responds with 200 with the uuid" $ 33 | Utils.postSimpleJSON reqPath reqBody 34 | `shouldRespondWith` "myResp" {matchStatus = 200} 35 | 36 | describe "email collision" $ do 37 | let coll = Lib.emptyLogicH {UC._userRegister = \_ _ _ -> pure $ Left (UC.ErrValidation [])} 38 | with (start coll) $ 39 | it "responds with 422" $ 40 | Utils.postSimpleJSON reqPath reqBody 41 | `shouldRespondWith` "" {matchStatus = 422} 42 | -------------------------------------------------------------------------------- /test/Http/Utils.hs: -------------------------------------------------------------------------------- 1 | module Http.Utils where 2 | 3 | import Network.HTTP.Types 4 | import qualified Network.Wai.Test as W 5 | import RIO 6 | import qualified RIO.ByteString.Lazy as LB 7 | import Test.Hspec.Wai 8 | 9 | postSimpleJSON :: ByteString -> LB.ByteString -> WaiSession st W.SResponse 10 | postSimpleJSON path = request methodPost path [(hContentType, "application/json")] 11 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | 3 | -- Just a helper file in order to let hspec discover all specs in this folder and subfolders 4 | -------------------------------------------------------------------------------- /test/Storage/HasqlSpec.hs: -------------------------------------------------------------------------------- 1 | module Storage.HasqlSpec where 2 | 3 | import qualified Domain.User as D 4 | import RIO 5 | import qualified Storage.Lib as Lib 6 | import qualified Storage.Specs.User as UserRepo 7 | import Test.Hspec 8 | import qualified TestContainers.Hspec as TC 9 | import qualified Usecase.Interactor as UC 10 | import Utils 11 | 12 | spec :: Spec 13 | spec = 14 | aroundAll (TC.withContainers Lib.startAndConnectPostgres) $ do 15 | UserRepo.getUserSpec 16 | UserRepo.insertUserSpec 17 | -------------------------------------------------------------------------------- /test/Storage/Lib.hs: -------------------------------------------------------------------------------- 1 | module Storage.Lib where 2 | 3 | --import Control.Monad.Fail 4 | 5 | import qualified Adapter.Fake.Logger as Logger 6 | import qualified Adapter.Storage.Hasql.User as Storage 7 | import Control.Exception 8 | import Data.Text (pack) 9 | import Data.Text.Lazy (isInfixOf) 10 | import qualified Domain.Messages as D 11 | import qualified Domain.User as D 12 | import qualified Hasql.Connection as HConn 13 | import qualified Hasql.Decoders as HD 14 | import qualified Hasql.Encoders as HE 15 | import Hasql.Session 16 | import qualified Hasql.Session as Session 17 | import qualified Hasql.Statement as HS 18 | import qualified Hasql.TH as TH 19 | import RIO 20 | import System.Directory as System 21 | import System.IO as System 22 | import Test.Hspec 23 | import qualified TestContainers.Hspec as TC 24 | import qualified Usecase.Interactor as UC 25 | import Utils 26 | 27 | type Logs = TVar Logger.Logs 28 | 29 | newtype App a = App (RIO Logs a) deriving (Functor, Applicative, Monad, MonadReader Logs, MonadIO) 30 | 31 | instance MonadFail App where 32 | fail = fail 33 | 34 | instance UC.Logger App where 35 | log = Logger.log 36 | 37 | run :: Logs -> App a -> IO a 38 | run logs (App app) = runRIO logs app 39 | 40 | type ResetFunc m = Monad m => () -> m () 41 | 42 | data TestException 43 | = PgConnectionFailed HConn.ConnectionError 44 | | PgQueryFailed QueryError 45 | deriving (Show, Typeable) 46 | 47 | instance Exception TestException 48 | 49 | startAndConnectPostgres :: TC.MonadDocker m => m HConn.Connection 50 | startAndConnectPostgres = do 51 | let pgPassword = "pg_password" 52 | 53 | currDir <- liftIO getCurrentDirectory 54 | 55 | pgContainer <- 56 | TC.run $ 57 | TC.containerRequest (TC.fromTag "postgres:14") 58 | TC.& TC.setExpose [5432] 59 | TC.& TC.setEnv [("POSTGRES_PASSWORD", pgPassword)] 60 | TC.& TC.setVolumeMounts [(pack currDir <> "/scripts/pg.sql", "/docker-entrypoint-initdb.d/init.sql")] 61 | TC.& TC.setWaitingFor (TC.waitForLogLine TC.Stdout ("PostgreSQL init process complete; ready for start up." `isInfixOf`)) 62 | 63 | conn <- 64 | liftIO $ 65 | HConn.acquire $ 66 | HConn.settings 67 | "localhost" 68 | (fromIntegral $ TC.containerPort pgContainer 5432) 69 | "postgres" 70 | (encodeUtf8 pgPassword) 71 | "postgres" 72 | 73 | case conn of 74 | Right c -> pure c 75 | Left e -> throwM $ PgConnectionFailed e 76 | 77 | resetDbAndFlushLogs :: HConn.Connection -> IO (UC.UserRepo App, HConn.Connection, Logs) 78 | resetDbAndFlushLogs conn = do 79 | logs <- emptyLogs 80 | truncateTable conn 81 | pure (userRepo conn, conn, logs) 82 | where 83 | emptyLogs = newTVarIO [] 84 | userRepo conn = 85 | UC.UserRepo 86 | (Storage.insertUserPswd conn) 87 | (Storage.getUserByID conn) 88 | (Storage.getUserByEmail conn) 89 | (Storage.getUserByName conn) 90 | undefined 91 | 92 | truncateTable :: (MonadFail m, MonadIO m) => HConn.Connection -> m () 93 | truncateTable c = do 94 | Right res <- liftIO $ Session.run (Session.statement () truncateStmt) c 95 | pure () 96 | 97 | truncateStmt :: HS.Statement () () 98 | truncateStmt = HS.Statement "truncate table users" HE.noParams HD.noResult True 99 | -------------------------------------------------------------------------------- /test/Storage/Specs/User.hs: -------------------------------------------------------------------------------- 1 | module Storage.Specs.User (getUserSpec, insertUserSpec) where 2 | 3 | import Adapter.Fake.Logger (getLogs) 4 | import Data.Text.Array (empty) 5 | import qualified Data.UUID as UUID 6 | import qualified Domain.Messages as D 7 | import qualified Domain.User as D 8 | import qualified Hasql.Decoders as HD 9 | import qualified Hasql.Encoders as HE 10 | import qualified Hasql.Session as Session 11 | import qualified Hasql.Statement as HS 12 | import qualified Hasql.TH as TH 13 | import RIO 14 | import Storage.Lib (truncateTable) 15 | import qualified Storage.Lib as Lib 16 | import Test.Hspec 17 | import Usecase.Interactor (Err (AnyErr)) 18 | import qualified Usecase.Interactor as UC 19 | import Utils 20 | 21 | -- todo : check the logs 22 | getUserSpec = 23 | beforeWith Lib.resetDbAndFlushLogs $ do 24 | -- all the functions below are expected to share the same behavior : 25 | -- get the user, but from different fields 26 | describe "getUserByID" $ 27 | runTests (UC._getUserByID, D._id user) 28 | describe "getUserByName" $ 29 | runTests (UC._getUserByName, D._name user) 30 | describe "getUserByEmail" $ 31 | runTests (UC._getUserByEmail, D._email user) 32 | where 33 | runTests (getUserBy, arg) = do 34 | it "returns the user if present" $ \(repo, conn, logs) -> do 35 | Right result <- Lib.run logs $ do 36 | Nothing <- UC._insertUserPswd repo user emptyPassword 37 | Nothing <- UC._insertUserPswd repo otherUser emptyPassword 38 | getUserBy repo arg 39 | result `shouldBe` Just user 40 | 41 | it "returns nothing if not found" $ \(repo, conn, logs) -> do 42 | Right result <- Lib.run logs $ do 43 | Nothing <- UC._insertUserPswd repo otherUser emptyPassword 44 | getUserBy repo arg 45 | result `shouldBe` Nothing 46 | 47 | it "returns an error if something goes wrong" $ \(repo, conn, logs) -> do 48 | Left result <- Lib.run logs $ do 49 | Nothing <- UC._insertUserPswd repo user emptyPassword 50 | Right _ <- liftIO $ Session.run (Session.statement () dropColumnStmt) conn 51 | getUserBy repo arg 52 | result `shouldBe` AnyErr 53 | truncateTable conn 54 | Right _ <- liftIO $ Session.run (Session.statement () restoreColumnStmt) conn 55 | pure () 56 | 57 | insertUserSpec = 58 | beforeWith Lib.resetDbAndFlushLogs $ do 59 | describe "insertUser" $ do 60 | it "succeeds for a valid user" $ \(repo, conn, logs) -> do 61 | result <- Lib.run logs $ do 62 | UC._insertUserPswd repo user (D.Password "password") 63 | result `shouldBe` Nothing 64 | 65 | it "succeeds for a user with a password" $ \(repo, conn, logs) -> do 66 | result <- Lib.run logs $ do 67 | UC._insertUserPswd repo user emptyPassword 68 | result `shouldBe` Nothing 69 | 70 | it "succeeds on password collision" $ \(repo, conn, logs) -> do 71 | result <- Lib.run logs $ do 72 | let password = D.Password "password" 73 | Nothing <- UC._insertUserPswd repo user password 74 | UC._insertUserPswd repo otherUser password 75 | result `shouldBe` Nothing 76 | 77 | it "fails if the user has no name" $ \(repo, conn, logs) -> do 78 | result <- Lib.run logs $ UC._insertUserPswd repo (user {D._name = D.Name ""}) emptyPassword 79 | result `shouldBe` Just UC.AnyErr 80 | ll <- readTVarIO logs 81 | length ll `shouldBe` 1 82 | 83 | it "fails if the user has no email" $ \(repo, conn, logs) -> do 84 | result <- Lib.run logs $ UC._insertUserPswd repo (user {D._email = D.Email ""}) emptyPassword 85 | result `shouldBe` Just UC.AnyErr 86 | ll <- readTVarIO logs 87 | length ll `shouldBe` 1 88 | 89 | it "fails with conflict on id collision" $ 90 | \(repo, conn, logs) -> do 91 | result <- Lib.run logs $ do 92 | Nothing <- UC._insertUserPswd repo user emptyPassword 93 | UC._insertUserPswd repo (otherUser {D._id = userUUID}) emptyPassword 94 | result `shouldBe` Just (UC.SpecificErr UC.InsertUserConflict) 95 | ll <- readTVarIO logs 96 | length ll `shouldBe` 1 97 | 98 | it "fails with conflict on name collision" $ \(repo, conn, logs) -> do 99 | result <- Lib.run logs $ do 100 | Nothing <- UC._insertUserPswd repo user emptyPassword 101 | UC._insertUserPswd repo (otherUser {D._name = D._name user}) emptyPassword 102 | result `shouldBe` Just (UC.SpecificErr UC.InsertUserConflict) 103 | ll <- readTVarIO logs 104 | length ll `shouldBe` 1 105 | 106 | it "fails with conflict on email collision" $ \(repo, conn, logs) -> do 107 | result <- Lib.run logs $ do 108 | Nothing <- UC._insertUserPswd repo user emptyPassword 109 | UC._insertUserPswd repo (otherUser {D._email = D._email user}) emptyPassword 110 | result `shouldBe` Just (UC.SpecificErr UC.InsertUserConflict) 111 | ll <- readTVarIO logs 112 | length ll `shouldBe` 1 113 | 114 | --shouldContainAnError :: [D.Message a] -> Bool 115 | --shouldContainAnError = any isError 116 | -- where 117 | -- isError m = case m of 118 | -- D.ErrorMsg _ -> True 119 | -- _ -> False 120 | 121 | -- helpers 122 | dropColumnStmt :: HS.Statement () () 123 | dropColumnStmt = 124 | HS.Statement "ALTER TABLE users DROP COLUMN uid" HE.noParams HD.noResult True 125 | 126 | restoreColumnStmt :: HS.Statement () () 127 | restoreColumnStmt = 128 | HS.Statement "ALTER TABLE users ADD COLUMN uid UUID NOT NULL UNIQUE" HE.noParams HD.noResult True 129 | 130 | emptyPassword = D.Password "" 131 | 132 | userUUID = fakeUUID1 133 | 134 | user = D.User userUUID (D.Name "userName") (D.Email "user@email.com") 135 | 136 | otherUser = D.User fakeUUID2 (D.Name "otherUserName") (D.Email "otherUser@email.com") 137 | -------------------------------------------------------------------------------- /test/Usecase/Lib.hs: -------------------------------------------------------------------------------- 1 | module Usecase.Lib where 2 | 3 | import qualified Adapter.Fake.Logger as Fake 4 | import qualified Adapter.Logger as Katip 5 | import qualified Adapter.Storage.InMem.User as UserRepo 6 | import RIO 7 | import Usecase.Interactor 8 | 9 | type State = (TVar UserRepo.Store, TVar Fake.Logs) 10 | 11 | newtype App a = App (RIO State a) 12 | deriving 13 | (Functor, Applicative, Monad, MonadUnliftIO, MonadThrow, MonadReader State, MonadIO) 14 | 15 | run :: State -> App a -> IO a 16 | run globalState (App app) = runRIO globalState app 17 | 18 | instance Logger App where 19 | log = Fake.log 20 | -------------------------------------------------------------------------------- /test/Usecase/Specs/UserLoginSpec.hs: -------------------------------------------------------------------------------- 1 | module Usecase.Specs.UserLoginSpec 2 | ( spec, 3 | ) 4 | where 5 | 6 | import qualified Adapter.Storage.InMem.User as UserRepo 7 | import qualified Data.UUID as UUID 8 | import qualified Domain.User as D 9 | import RIO 10 | import Test.Hspec 11 | import Usecase.Lib 12 | import qualified Usecase.UserLogin as UC 13 | import Usecase.Utils 14 | import Utils 15 | 16 | uc :: UC.Login App 17 | uc = UC.login (\t -> pure $ "hashed-" <> t) UserRepo.getUserByEmailAndHashedPassword 18 | 19 | loginUser :: State -> UC.Login IO 20 | loginUser state = run state . uc 21 | 22 | insertUserPswd_ :: D.User -> D.Password -> IO State 23 | insertUserPswd_ user password = do 24 | state <- emptyState 25 | Nothing <- run state $ UserRepo.insertUserPswd user password 26 | pure state 27 | 28 | spec :: Spec 29 | spec = do 30 | let userEmail = D.Email "userEmail" 31 | userPassword = D.Password "userPassword" 32 | userName = D.Name "userName" 33 | myUser = D.User fakeUUID1 userName userEmail 34 | 35 | describe "happy case" $ 36 | it "returns an uuid if found" $ do 37 | state <- insertUserPswd_ myUser (D.Password "hashed-" <> userPassword) 38 | foundUser <- loginUser state $ D.LoginDetails userEmail userPassword 39 | foundUser `shouldBe` Right myUser 40 | 41 | describe "not found" $ 42 | it "returns a ErrUserNotFound" $ do 43 | state <- insertUserPswd_ myUser userPassword 44 | notFoundUser <- loginUser state $ D.LoginDetails (userEmail <> D.Email "oops") userPassword 45 | notFoundUser `shouldBe` Left UC.UserNotFound 46 | describe "not found 2" $ 47 | it "returns a ErrUserNotFound" $ do 48 | state <- insertUserPswd_ myUser userPassword 49 | notFoundUser <- loginUser state $ D.LoginDetails userEmail (userPassword <> D.Password "oops") 50 | notFoundUser `shouldBe` Left UC.UserNotFound 51 | -------------------------------------------------------------------------------- /test/Usecase/Specs/UserRegistrationSpec.hs: -------------------------------------------------------------------------------- 1 | module Usecase.Specs.UserRegistrationSpec 2 | ( spec, 3 | ) 4 | where 5 | 6 | import qualified Adapter.EmailChecker as MailChecker 7 | import qualified Adapter.Fake.Logger as Logger 8 | import qualified Adapter.Fake.UUID as Uuid 9 | import qualified Adapter.Storage.InMem.User as InMem 10 | import qualified Data.UUID as UUID 11 | import qualified Domain.User as D 12 | import RIO 13 | import Test.Hspec 14 | import qualified Usecase.Interactor as UC 15 | import Usecase.Lib 16 | import qualified Usecase.UserRegistration as UC 17 | import Usecase.Utils 18 | import Utils 19 | 20 | uc :: UC.Register App 21 | uc = 22 | UC.register 23 | (Uuid.genUUID fakeUUID1) 24 | MailChecker.checkEmailFormat 25 | InMem.getUserByEmail 26 | InMem.getUserByName 27 | InMem.insertUserPswd 28 | 29 | registerUser :: MonadIO m => State -> UC.Register m 30 | registerUser st name email pswd = liftIO $ run st $ uc name email pswd 31 | 32 | spec :: Spec 33 | spec = do 34 | let prevUsr = D.User fakeUUID1 (D.Name "collidingUserName") (D.Email "colliding@email.fr") 35 | currUsr = D.User fakeUUID2 (D.Name "currentUserName") (D.Email "current@email.fr") 36 | malformedEmail = D.Email "current.email.fr" 37 | pswd = D.Password "myPass" 38 | insertPrev st = run st $ InMem.insertUserPswd prevUsr pswd 39 | 40 | before emptyState $ do 41 | describe "happy case" $ 42 | it "should return the uuid" $ \st -> do 43 | Right uuid <- registerUser st (D._name currUsr) (D._email currUsr) pswd 44 | uuid `shouldBe` UUID.toText fakeUUID1 45 | 46 | describe "collision with other user email" $ 47 | it "raises an UserEmailAlreadyInUse error" $ 48 | \st -> do 49 | insertPrev st 50 | Left (UC.ErrValidation resp) <- registerUser st (D._name currUsr) (D._email prevUsr) pswd 51 | resp `shouldBe` [UC.EmailConflict] 52 | 53 | describe "collision with other user name" $ -- 54 | it "raises an UserNameAlreadyInUse error" $ 55 | \st -> do 56 | insertPrev st 57 | Left (UC.ErrValidation resp) <- registerUser st (D._name prevUsr) (D._email currUsr) pswd 58 | resp `shouldBe` [UC.NameConflict] 59 | 60 | describe "collision with other user name & other user email" $ 61 | it "raises UserNameAlreadyInUse & UserEmailAlreadyInUse errors" $ 62 | \st -> do 63 | insertPrev st 64 | Left (UC.ErrValidation resp) <- registerUser st (D._name prevUsr) (D._email prevUsr) pswd 65 | resp `shouldMatchList` [UC.NameConflict, UC.EmailConflict] 66 | 67 | describe "malformed email" $ 68 | it "raises an MalformedEmail error" $ \st -> do 69 | Left (UC.ErrValidation resp) <- registerUser st (D._name currUsr) malformedEmail pswd 70 | resp `shouldMatchList` [UC.MalformedEmail] 71 | -------------------------------------------------------------------------------- /test/Usecase/Utils.hs: -------------------------------------------------------------------------------- 1 | module Usecase.Utils where 2 | 3 | import qualified Adapter.Fake.Logger as Logger 4 | import qualified Adapter.Fake.UUID as GenUUID 5 | import qualified Adapter.Storage.InMem.User as UserRepo 6 | import RIO 7 | import Test.Hspec 8 | import Usecase.Lib 9 | import Utils 10 | 11 | -- creates an empty state 12 | emptyState :: (MonadIO m) => m State 13 | emptyState = do 14 | state <- newTVarIO $ UserRepo.Store mempty 15 | logger <- newTVarIO [] 16 | uuid <- newTVarIO $ GenUUID.UUIDGen fakeUUID1 17 | return (state, logger) 18 | 19 | checkLogs :: (Show a) => State -> [a] -> IO () 20 | checkLogs state expectedLogs = do 21 | logs <- run state Logger.getLogs 22 | length logs `shouldBe` length expectedLogs 23 | logs `shouldMatchList` map tshow expectedLogs 24 | -------------------------------------------------------------------------------- /test/Utils.hs: -------------------------------------------------------------------------------- 1 | module Utils where 2 | 3 | import qualified Data.UUID as UUID 4 | import qualified Domain.User as D 5 | import RIO 6 | 7 | -- used for tests 8 | fakeUUID1 :: UUID.UUID 9 | fakeUUID1 = getUUID "a0eebc99-9c0b-4ef8-bb6d-6bb9bd380a11" 10 | 11 | fakeUUID2 :: UUID.UUID 12 | fakeUUID2 = getUUID "61b4ea9a-cfdb-44cc-b40b-affffeedc14e" 13 | 14 | getUUID :: Text -> UUID.UUID 15 | getUUID txt = do 16 | let Just uuid = UUID.fromText txt 17 | uuid 18 | --------------------------------------------------------------------------------