├── logs └── .gitkeep ├── database ├── dune └── pizza.ml ├── app ├── schedule │ └── dune ├── command │ ├── dune │ └── command.ml ├── job │ ├── dune │ └── job.ml └── context │ └── pizza │ ├── dune │ ├── pizza.mli │ ├── model.ml │ ├── pizza.ml │ └── repo.ml ├── CHANGES.md ├── web ├── middleware │ ├── dune │ └── authn.ml ├── handler │ ├── page.ml │ ├── dune │ ├── welcome.ml │ ├── pizzas.ml │ └── auth.ml └── view │ ├── dune │ ├── pizzas.ml │ ├── welcome.ml │ ├── hello.ml │ ├── layout.ml │ ├── auth.ml │ └── ingredients.ml ├── routes ├── dune └── routes.ml ├── service ├── dune └── service.ml ├── .ocamlformat ├── dune ├── .env.test ├── run ├── dune └── run.ml ├── .parcelrc ├── test └── pizza │ ├── dune │ └── test.ml ├── public ├── styles.css └── reset.css ├── resources ├── styles.css └── reset.css ├── .env ├── default.nix ├── .gitignore ├── docker ├── docker-compose.dev.yml └── Dockerfile ├── .gitattributes ├── dune-project ├── README.md ├── pizza.opam ├── .devcontainer ├── docker-compose.yml ├── postCreate.sh ├── README.md ├── Dockerfile └── devcontainer.json ├── LICENSE ├── CONTRIBUTING.md ├── .github └── workflows │ └── ci.yml ├── Makefile └── pizza.opam.locked /logs/.gitkeep: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /database/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name database) 3 | (libraries sihl)) 4 | -------------------------------------------------------------------------------- /app/schedule/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name schedule) 3 | (libraries sihl)) 4 | -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | # 0.1.0 - 2020-01-01 2 | 3 | ## Added 4 | 5 | - Initial release 6 | -------------------------------------------------------------------------------- /app/command/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name command) 3 | (libraries sihl pizza job)) 4 | -------------------------------------------------------------------------------- /web/middleware/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name middleware) 3 | (libraries service sihl)) 4 | -------------------------------------------------------------------------------- /app/job/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name job) 3 | (libraries sihl service pizza sihl-queue)) 4 | -------------------------------------------------------------------------------- /routes/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name routes) 3 | (libraries sihl view handler middleware)) 4 | -------------------------------------------------------------------------------- /service/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name service) 3 | (libraries sihl sihl-user sihl-queue)) 4 | -------------------------------------------------------------------------------- /web/handler/page.ml: -------------------------------------------------------------------------------- 1 | let hello _ = Lwt.return @@ Sihl.Web.Response.of_html View.Hello.page 2 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = janestreet 2 | parse-docstrings = true 3 | wrap-comments = true 4 | margin = 80 -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (env 2 | (dev 3 | (flags 4 | (:standard -open StdLabels -w +A-48-42-44 -warn-error +A-3)))) 5 | -------------------------------------------------------------------------------- /.env.test: -------------------------------------------------------------------------------- 1 | SIHL_SECRET=secret 2 | DATABASE_URL=postgres://admin:password@127.0.0.1:5432/dev 3 | DATABASE_POOL_SIZE=10 4 | -------------------------------------------------------------------------------- /run/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name run) 3 | (libraries sihl service routes database command caqti-driver-postgresql)) 4 | -------------------------------------------------------------------------------- /web/view/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name view) 3 | (libraries tyxml sihl service pizza) 4 | (preprocess 5 | (pps tyxml-ppx))) 6 | -------------------------------------------------------------------------------- /.parcelrc: -------------------------------------------------------------------------------- 1 | { 2 | "extends": "@parcel/config-default", 3 | "transformers": { 4 | "*": ["@parcel/transformer-raw"] 5 | } 6 | } -------------------------------------------------------------------------------- /web/handler/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name handler) 3 | (libraries service sihl pizza view) 4 | (preprocess 5 | (pps tyxml-ppx))) 6 | -------------------------------------------------------------------------------- /test/pizza/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name test) 3 | (libraries sihl service database alcotest alcotest-lwt 4 | caqti-driver-postgresql pizza)) 5 | -------------------------------------------------------------------------------- /service/service.ml: -------------------------------------------------------------------------------- 1 | module Migration = Sihl.Database.Migration.PostgreSql 2 | module User = Sihl_user.PostgreSql 3 | module Queue = Sihl_queue.PostgreSql 4 | -------------------------------------------------------------------------------- /app/context/pizza/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name pizza) 3 | (libraries sihl service) 4 | (preprocess 5 | (pps ppx_fields_conv ppx_deriving.eq ppx_deriving.show ppx_deriving.make))) 6 | -------------------------------------------------------------------------------- /web/view/pizzas.ml: -------------------------------------------------------------------------------- 1 | open Tyxml 2 | 3 | let index user = 4 | let ingredients = [%html {|List of pizzas.|}] in 5 | Layout.page (Some user) [ ingredients ] 6 | ;; 7 | -------------------------------------------------------------------------------- /web/view/welcome.ml: -------------------------------------------------------------------------------- 1 | open Tyxml 2 | 3 | let page user = 4 | let welcome = [%html {|Welcome to Vinnie's Pizza Place.|}] in 5 | Layout.page user [ welcome ] 6 | ;; 7 | -------------------------------------------------------------------------------- /web/handler/welcome.ml: -------------------------------------------------------------------------------- 1 | let index req = 2 | let open Lwt.Syntax in 3 | let* user = Service.User.Web.user_from_session req in 4 | Lwt.return @@ Sihl.Web.Response.of_html (View.Welcome.page user) 5 | ;; 6 | -------------------------------------------------------------------------------- /public/styles.css: -------------------------------------------------------------------------------- 1 | .container { 2 | margin-top: 50px; 3 | } 4 | 5 | .hello { 6 | font-size: 40px; 7 | color: grey; 8 | font-weight: 600; 9 | text-align: center; 10 | } 11 | 12 | .alert { 13 | color: red; 14 | } 15 | 16 | .notice { 17 | color: green; 18 | } 19 | -------------------------------------------------------------------------------- /resources/styles.css: -------------------------------------------------------------------------------- 1 | .container { 2 | margin-top: 50px; 3 | } 4 | 5 | .hello { 6 | font-size: 40px; 7 | color: grey; 8 | font-weight: 600; 9 | text-align: center; 10 | } 11 | 12 | .alert { 13 | color: red; 14 | } 15 | 16 | .notice { 17 | color: green; 18 | } 19 | -------------------------------------------------------------------------------- /.env: -------------------------------------------------------------------------------- 1 | SIHL_SECRET=secret 2 | DATABASE_URL=postgres://admin:password@127.0.0.1:5432/dev 3 | DATABASE_POOL_SIZE=10 4 | SMTP_SENDER=sender@example.com 5 | SMTP_PORT=587 6 | SMTP_USERNAME=user 7 | SMTP_HOST=smtp.example.com 8 | SMTP_START_TLS=true 9 | SMTP_PASSWORD=yourpassword 10 | CA_DIR=/etc/ssl/certs 11 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | with import { }; 2 | 3 | mkShell { 4 | buildInputs = [ zlib.dev zlib.out zlib zlib.all gmp gmp.dev pkgconfig openssl libev libevdev mariadb-client mariadb-connector-c postgresql lsof ]; 5 | LD_LIBRARY_PATH = "${mariadb-connector-c}/lib/mariadb"; 6 | shellHook = "eval $(opam env)"; 7 | } 8 | -------------------------------------------------------------------------------- /web/handler/pizzas.ml: -------------------------------------------------------------------------------- 1 | let index req = 2 | let open Lwt.Syntax in 3 | let* user = Service.User.Web.user_from_session req |> Lwt.map Option.get in 4 | Lwt.return @@ Sihl.Web.Response.of_html (View.Pizzas.index user) 5 | ;; 6 | 7 | let create _ = failwith "todo pizza create" 8 | let delete _ = failwith "todo pizza delete" 9 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # ocamlbuild working directory 2 | _build/ 3 | 4 | # ocamlbuild targets 5 | *.byte 6 | *.native 7 | 8 | # Merlin configuring file for Vim and Emacs 9 | .merlin 10 | 11 | # Dune generated files 12 | *.install 13 | 14 | # Local OPAM switch 15 | _opam/ 16 | 17 | # vscode devcontainer data 18 | .devcontainer/data/ 19 | 20 | # Logs 21 | logs/* 22 | -------------------------------------------------------------------------------- /docker/docker-compose.dev.yml: -------------------------------------------------------------------------------- 1 | version: "3.1" 2 | 3 | services: 4 | database: 5 | image: postgres:12.2 6 | restart: always 7 | environment: 8 | POSTGRES_USER: admin 9 | POSTGRES_PASSWORD: password 10 | POSTGRES_DB: dev 11 | ports: 12 | - 5432:5432 13 | 14 | adminer: 15 | image: adminer:4.7.6-standalone 16 | restart: always 17 | ports: 18 | - 8080:8080 19 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Tell github that .ml and .mli files are OCaml 2 | *.ml linguist-language=OCaml 3 | *.mli linguist-language=OCaml 4 | # Disable syntax detection for .spin 5 | .spin linguist-language=Text 6 | 7 | # Declare shell files to have LF endings on checkout 8 | # On Windows, the default git setting for `core.autocrlf` 9 | # means that when checking out code, LF endings get converted 10 | # to CRLF. This causes problems for shell scripts, as bash 11 | # gets choked up on the extra `\r` character. 12 | * text eol=lf 13 | -------------------------------------------------------------------------------- /web/view/hello.ml: -------------------------------------------------------------------------------- 1 | open Tyxml 2 | 3 | let%html page = 4 | {| 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | Hello world! 13 | 14 | 15 |
16 |

Hello world!

17 |
18 | 19 | 20 | |} 21 | ;; 22 | -------------------------------------------------------------------------------- /app/job/job.ml: -------------------------------------------------------------------------------- 1 | let cook_pizza = 2 | Sihl_queue.create_job 3 | (fun pizza_name -> 4 | Pizza.create_pizza pizza_name [] |> Lwt.map ignore |> Lwt.map Result.ok) 5 | (fun s -> s) 6 | (fun s -> Ok s) 7 | "cook-pizza" 8 | ;; 9 | 10 | let order_ingredient = 11 | Sihl_queue.create_job 12 | (fun ingredient_name -> 13 | Pizza.Ingredient.create ingredient_name false 10 |> Lwt_result.map ignore) 14 | (fun s -> s) 15 | (fun s -> Ok s) 16 | "order-ingredient" 17 | ;; 18 | 19 | let all = [ Sihl_queue.hide cook_pizza; Sihl_queue.hide order_ingredient ] 20 | -------------------------------------------------------------------------------- /web/middleware/authn.ml: -------------------------------------------------------------------------------- 1 | (* Put custom Opium middlewares here *) 2 | 3 | (* [middleware login_path] returns a middleware that redirects to [login_path] 4 | if no user is present. Use it to enforce authentication on routers. *) 5 | let middleware login_path = 6 | let filter handler req = 7 | let open Lwt.Syntax in 8 | let* user = Service.User.Web.user_from_session req in 9 | match user with 10 | | None -> Lwt.return @@ Sihl.Web.Response.redirect_to login_path 11 | | Some _ -> handler req 12 | in 13 | Rock.Middleware.create ~name:"authentication" ~filter 14 | ;; 15 | -------------------------------------------------------------------------------- /run/run.ml: -------------------------------------------------------------------------------- 1 | (* This is the entry point to the Sihl app. 2 | 3 | The parts of your app come together here and are wired to the services. This 4 | is also the central registry for infrastructure services. *) 5 | 6 | let services = 7 | [ Sihl.Database.register () 8 | ; Service.Migration.register [ Database.Pizza.migration ] 9 | ; Sihl.Web.Http.register ~middlewares:Routes.global_middlewares Routes.all 10 | ; Service.User.register () 11 | ; Service.Queue.register ~jobs:Job.all () 12 | ] 13 | ;; 14 | 15 | let () = Sihl.App.(empty |> with_services services |> run ~commands:Command.all) 16 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | 3 | (name pizza) 4 | 5 | (documentation "https://oxidizing.github.io/pizza/") 6 | 7 | (source 8 | (github oxidizing/pizza)) 9 | 10 | (license MIT) 11 | 12 | (authors 13 | "Josef Erben") 14 | 15 | (maintainers 16 | "Josef Erben") 17 | 18 | (generate_opam_files true) 19 | 20 | (package 21 | (name pizza) 22 | (synopsis "A restaurant serving Pizza and sometimes Lasagna") 23 | (description "\ 24 | A restaurant serving Pizza and sometimes Lasagna 25 | ") 26 | (depends 27 | (ocaml (>= 4.08.0)) 28 | dune 29 | (sihl (= 1.0.0~rc2)) 30 | (sihl-user (= 1.0.0~rc2)) 31 | (sihl-queue (= 1.0.0~rc2)) 32 | (tyxml-ppx (>= 4.4.0)) 33 | (caqti-driver-postgresql (>= 1.2.1)) 34 | (alcotest-lwt :with-test) 35 | (odoc :with-doc))) 36 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Sihl demo app 2 | 3 | A restaurant serving pizza and sometimes lasagna, delicious lasagna. 4 | 5 | This is an app that demonstrates the usage of the web framework [Sihl](https://github.com/oxidizing/sihl/). The goal is to showcase every feature of Sihl. 6 | 7 | ## Quickstart 8 | 9 | Keep on going with the following commands or use the [DevContainer setup](./.devcontainer/README.md). 10 | 11 | 1. After cloning the repository, create an opam switch: 12 | 13 | ``` 14 | make switch 15 | ``` 16 | 17 | 2. Start the database using docker: 18 | 19 | ``` 20 | make db 21 | ``` 22 | 23 | 3. Run migrations: 24 | 25 | ``` 26 | make sihl migrate 27 | ``` 28 | 29 | 4. Run the development server: 30 | 31 | ``` 32 | make dev 33 | ``` 34 | 35 | 5. Go to localhost:3000 36 | 37 | ## Contributing 38 | 39 | Take a look at our [Contributing Guide](CONTRIBUTING.md). 40 | -------------------------------------------------------------------------------- /pizza.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | synopsis: "A restaurant serving Pizza and sometimes Lasagna" 4 | description: """ 5 | A restaurant serving Pizza and sometimes Lasagna 6 | """ 7 | maintainer: ["Josef Erben"] 8 | authors: ["Josef Erben"] 9 | license: "MIT" 10 | homepage: "https://github.com/oxidizing/pizza" 11 | doc: "https://oxidizing.github.io/pizza/" 12 | bug-reports: "https://github.com/oxidizing/pizza/issues" 13 | depends: [ 14 | "ocaml" {>= "4.08.0"} 15 | "dune" 16 | "sihl" {= "1.0.0~rc2"} 17 | "sihl-user" {= "1.0.0~rc2"} 18 | "sihl-queue" {= "1.0.0~rc2"} 19 | "tyxml-ppx" {>= "4.4.0"} 20 | "caqti-driver-postgresql" {>= "1.2.1"} 21 | "alcotest-lwt" {with-test} 22 | "odoc" {with-doc} 23 | ] 24 | build: [ 25 | ["dune" "subst"] {pinned} 26 | [ 27 | "dune" 28 | "build" 29 | "-p" 30 | name 31 | "-j" 32 | jobs 33 | "@install" 34 | "@runtest" {with-test} 35 | "@doc" {with-doc} 36 | ] 37 | ] 38 | dev-repo: "git+https://github.com/oxidizing/pizza.git" 39 | -------------------------------------------------------------------------------- /.devcontainer/docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: '3.8' 2 | 3 | services: 4 | dev: 5 | build: 6 | context: . 7 | dockerfile: Dockerfile 8 | volumes: 9 | # default user is "opam" 10 | - ..:/workspace:cached 11 | - opam:/home/opam/.opam:cached 12 | - build:/workspace/_build:cached 13 | # - ${HOME}${USERPROFILE}/.ssh:/home/opam/.ssh 14 | # - ${HOME}${USERPROFILE}/.gitconfig:/home/opam/.gitconfig 15 | # - ${HOME}${USERPROFILE}/.gitignore_global:/home/opam/.gitignore_global 16 | depends_on: [database] 17 | ports: [3000:3000] 18 | command: /bin/sh -c "while sleep 1000; do :; done" 19 | 20 | 21 | database: 22 | image: postgres:12.2 23 | ports: [5432:5432] 24 | environment: 25 | TZ: Europe/Zurich 26 | POSTGRES_USER: admin 27 | POSTGRES_PASSWORD: password 28 | POSTGRES_DB: dev 29 | volumes: 30 | - ./data/db:/var/lib/postgresql/data 31 | 32 | adminer: 33 | image: adminer:4.7.6-standalone 34 | restart: always 35 | ports: [8080:8080] 36 | depends_on: [database] 37 | 38 | volumes: 39 | opam: 40 | build: 41 | -------------------------------------------------------------------------------- /.devcontainer/postCreate.sh: -------------------------------------------------------------------------------- 1 | # ocaml/opam post create script 2 | 3 | sudo chown -R opam: _build 4 | 5 | # remove and update default ocaml remote 6 | # make sure that opam finds latest package versions 7 | # (b.c. alcotest latest version is 1.1.0 instead of 1.2.1) 8 | opam remote remove --all default 9 | opam remote add default https://opam.ocaml.org 10 | 11 | # Pins 12 | # opam pin add -yn ocaml-lsp-server https://github.com/ocaml/ocaml-lsp.git 13 | 14 | # install opam packages 15 | # e.g. when developing with emax, add also: utop merlin ocamlformat 16 | opam install caqti-driver-postgresql ocamlformat ocaml-lsp-server.1.4.0 sihl alcotest-lwt 17 | 18 | # install project dependancies 19 | # pin package 20 | opam pin add pizza.dev . --no-action 21 | # Query and install external dependencies 22 | opam depext pizza --yes --with-doc 23 | # install dependencies 24 | OPAMSOLVERTIMEOUT=180 opam install . --deps-only --with-doc --with-test --locked --unlock-base 25 | opam install ocamlformat --skip-updates 26 | # upgrade dependencies 27 | opam upgrade --fixup 28 | 29 | # initialize project and update environmemnt 30 | opam init 31 | eval $(opam env) 32 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 Josef Erben 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. -------------------------------------------------------------------------------- /.devcontainer/README.md: -------------------------------------------------------------------------------- 1 | # VSCode setup 2 | 3 | ## Requirements 4 | 5 | This project is setup to run in a DevContainer. Ensure requirements to run in a DevContainer: 6 | 7 | 1. [Docker](/Technologies/Docker) installed 8 | 1. [Visual Studio Code](https://code.visualstudio.com/) (VS Code) installed 9 | 1. VS Code Extension [Remote Container](https://marketplace.visualstudio.com/items?itemName=ms-vscode-remote.remote-containers) installed 10 | 11 | ## Start DevContainer 12 | 13 | - Before starting the devcontainer make sure `DATABASE_URL` is deleted, commented or the host is set to `database` (instead of localhost) in `.env` file. 14 | 15 | Click on the icon similar to "><" in the bottom left corner and select `Remote-Containers: Reopen in Container`. 16 | If any changes were made to files in `.devcontainer` folder the Container should be rebuilt (`Remote-Containers: Rebuild Container`) 17 | 18 | ## Quickstart 19 | 20 | 1. Run migrations: 21 | 22 | ``` 23 | make sihl migrate 24 | ``` 25 | 26 | 1. Run the development server: 27 | 28 | ``` 29 | make dev 30 | ``` 31 | 32 | 1. Open Browser on `localhost:3000` 33 | 34 | [Back to main README](../README.md) 35 | -------------------------------------------------------------------------------- /web/view/layout.ml: -------------------------------------------------------------------------------- 1 | open Tyxml 2 | 3 | let navigation user = 4 | match user with 5 | | None -> 6 | [%html 7 | {| 8 | 12 | |}] 13 | | Some user -> 14 | [%html 15 | {| 16 | |}] 26 | ;; 27 | 28 | let%html page user body = 29 | {| 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | Hello world! 38 | 39 | |} 40 | [ navigation user ] 41 | {|
|} 42 | body 43 | {| 44 | 45 | 46 | |} 47 | ;; 48 | -------------------------------------------------------------------------------- /.devcontainer/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam2:4.11 2 | 3 | ENV DEBIAN_FRONTEND=noninteractive 4 | ENV SIHL_ENV development 5 | 6 | RUN sudo apt-get update -q && sudo apt-get install -yqq \ 7 | default-jre \ 8 | # emacs-nox for emacs, but sihl cannot be installed without 9 | emacs-nox \ 10 | inotify-tools \ 11 | libev-dev \ 12 | libffi-dev \ 13 | libfontconfig \ 14 | libgmp-dev \ 15 | libpq-dev \ 16 | libqt5gui5 \ 17 | libssl-dev \ 18 | lsof \ 19 | m4 \ 20 | pdftk-java \ 21 | perl \ 22 | pkg-config \ 23 | wget \ 24 | wkhtmltopdf \ 25 | xvfb \ 26 | zip \ 27 | zlib1g-dev \ 28 | zsh \ 29 | # cleanup installations 30 | && sudo apt-get clean all \ 31 | # install oh-my-zsh 32 | && wget https://github.com/robbyrussell/oh-my-zsh/raw/master/tools/install.sh -O - | zsh \ 33 | && cp ~/.oh-my-zsh/templates/zshrc.zsh-template ~/.zshrc \ 34 | # add timezone 35 | && sudo ln -fs /usr/share/zoneinfo/Europe/Zurich /etc/localtime 36 | 37 | # WTF: https://github.com/mirage/ocaml-cohttp/issues/675 38 | RUN sudo bash -c 'echo "http 80/tcp www # WorldWideWeb HTTP" >> /etc/services' \ 39 | sudo bash -c 'echo "https 443/tcp www # WorldWideWeb HTTPS" >> /etc/services' 40 | -------------------------------------------------------------------------------- /public/reset.css: -------------------------------------------------------------------------------- 1 | /* http://meyerweb.com/eric/tools/css/reset/ 2 | v2.0 | 20110126 3 | License: none (public domain) 4 | */ 5 | 6 | html, body, div, span, applet, object, iframe, 7 | h1, h2, h3, h4, h5, h6, p, blockquote, pre, 8 | a, abbr, acronym, address, big, cite, code, 9 | del, dfn, em, img, ins, kbd, q, s, samp, 10 | small, strike, strong, sub, sup, tt, var, 11 | b, u, i, center, 12 | dl, dt, dd, ol, ul, li, 13 | fieldset, form, label, legend, 14 | table, caption, tbody, tfoot, thead, tr, th, td, 15 | article, aside, canvas, details, embed, 16 | figure, figcaption, footer, header, hgroup, 17 | menu, nav, output, ruby, section, summary, 18 | time, mark, audio, video { 19 | margin: 0; 20 | padding: 0; 21 | border: 0; 22 | font-size: 100%; 23 | font: inherit; 24 | vertical-align: baseline; 25 | } 26 | /* HTML5 display-role reset for older browsers */ 27 | article, aside, details, figcaption, figure, 28 | footer, header, hgroup, menu, nav, section { 29 | display: block; 30 | } 31 | body { 32 | line-height: 1; 33 | } 34 | ol, ul { 35 | list-style: none; 36 | } 37 | blockquote, q { 38 | quotes: none; 39 | } 40 | blockquote:before, blockquote:after, 41 | q:before, q:after { 42 | content: ''; 43 | content: none; 44 | } 45 | table { 46 | border-collapse: collapse; 47 | border-spacing: 0; 48 | } 49 | -------------------------------------------------------------------------------- /resources/reset.css: -------------------------------------------------------------------------------- 1 | /* http://meyerweb.com/eric/tools/css/reset/ 2 | v2.0 | 20110126 3 | License: none (public domain) 4 | */ 5 | 6 | html, body, div, span, applet, object, iframe, 7 | h1, h2, h3, h4, h5, h6, p, blockquote, pre, 8 | a, abbr, acronym, address, big, cite, code, 9 | del, dfn, em, img, ins, kbd, q, s, samp, 10 | small, strike, strong, sub, sup, tt, var, 11 | b, u, i, center, 12 | dl, dt, dd, ol, ul, li, 13 | fieldset, form, label, legend, 14 | table, caption, tbody, tfoot, thead, tr, th, td, 15 | article, aside, canvas, details, embed, 16 | figure, figcaption, footer, header, hgroup, 17 | menu, nav, output, ruby, section, summary, 18 | time, mark, audio, video { 19 | margin: 0; 20 | padding: 0; 21 | border: 0; 22 | font-size: 100%; 23 | font: inherit; 24 | vertical-align: baseline; 25 | } 26 | /* HTML5 display-role reset for older browsers */ 27 | article, aside, details, figcaption, figure, 28 | footer, header, hgroup, menu, nav, section { 29 | display: block; 30 | } 31 | body { 32 | line-height: 1; 33 | } 34 | ol, ul { 35 | list-style: none; 36 | } 37 | blockquote, q { 38 | quotes: none; 39 | } 40 | blockquote:before, blockquote:after, 41 | q:before, q:after { 42 | content: ''; 43 | content: none; 44 | } 45 | table { 46 | border-collapse: collapse; 47 | border-spacing: 0; 48 | } 49 | -------------------------------------------------------------------------------- /app/context/pizza/pizza.mli: -------------------------------------------------------------------------------- 1 | type ingredient = 2 | { name : string 3 | ; is_vegan : bool 4 | ; price : int 5 | ; created_at : Ptime.t 6 | ; updated_at : Ptime.t 7 | } 8 | 9 | val ingredient_schema 10 | : (unit, string -> bool -> int -> ingredient, ingredient) Conformist.t 11 | 12 | type t = 13 | { name : string 14 | ; ingredients : string list 15 | ; created_at : Ptime.t 16 | ; updated_at : Ptime.t 17 | } 18 | 19 | exception Exception of string 20 | 21 | val clean : unit -> unit Lwt.t 22 | 23 | (** Ingredients *) 24 | 25 | module Ingredient : sig 26 | type t = ingredient 27 | 28 | val find : string -> t option Lwt.t 29 | 30 | val search 31 | : ?filter:string 32 | -> ?sort:[ `Desc | `Asc ] 33 | -> ?limit:int 34 | -> ?offset:int 35 | -> unit 36 | -> (t list * int) Lwt.t 37 | 38 | val create : string -> bool -> int -> (t, string) result Lwt.t 39 | val insert : t -> (t, string) result Lwt.t 40 | val update : string -> t -> (t, string) result Lwt.t 41 | val delete : t -> (unit, string) result Lwt.t 42 | end 43 | 44 | (** Pizzas *) 45 | 46 | val find_pizza : string -> t option Lwt.t 47 | val find_pizzas : unit -> t list Lwt.t 48 | val add_ingredient_to_pizza : string -> ingredient -> unit Lwt.t 49 | val create_pizza : string -> string list -> t Lwt.t 50 | val delete_pizza : t -> unit Lwt.t 51 | -------------------------------------------------------------------------------- /web/view/auth.ml: -------------------------------------------------------------------------------- 1 | open Tyxml 2 | 3 | let%html login_form csrf = 4 | {| 5 |
6 | 9 |
10 | 11 | 12 |
13 |
14 | 15 | 16 |
17 | 18 |
19 | |} 20 | ;; 21 | 22 | let login ~alert csrf = 23 | let alert_message = 24 | [%html {||} [ Html.txt (Option.value alert ~default:"") ] {||}] 25 | in 26 | Layout.page None [ alert_message; login_form csrf ] 27 | ;; 28 | 29 | let%html registration_form csrf = 30 | {| 31 |
32 | 35 |
36 | 37 | 38 |
39 |
40 | 41 | 42 |
43 |
44 | 45 | 46 |
47 | 48 |
49 | |} 50 | ;; 51 | 52 | let registration ~alert csrf = 53 | let alert_message = 54 | [%html {||} [ Html.txt (Option.value alert ~default:"") ] {||}] 55 | in 56 | Layout.page None [ alert_message; registration_form csrf ] 57 | ;; 58 | -------------------------------------------------------------------------------- /app/command/command.ml: -------------------------------------------------------------------------------- 1 | let create_pizza = 2 | Sihl.Command.make 3 | ~name:"pizza.create" 4 | ~help:" ..." 5 | ~description:"Creates a pizza immediately." 6 | (fun args -> 7 | match args with 8 | | name :: ingredients -> 9 | Pizza.create_pizza name ingredients 10 | |> Lwt.map ignore 11 | |> Lwt.map Option.some 12 | | _ -> 13 | raise 14 | (Sihl.Command.Exception 15 | "Usage: ")) 16 | ;; 17 | 18 | let cook_pizza = 19 | Sihl.Command.make 20 | ~name:"pizza.cook" 21 | ~help:"" 22 | ~description:"Starts cooking a pizza in 2 minutes" 23 | (fun args -> 24 | match args with 25 | | [ name ] -> 26 | Service.Queue.dispatch 27 | ~delay:(Sihl.Time.Span.minutes 2) 28 | name 29 | Job.cook_pizza 30 | |> Lwt.map Option.some 31 | | _ -> Lwt.return None) 32 | ;; 33 | 34 | let order_ingredient = 35 | Sihl.Command.make 36 | ~name:"pizza.ingredient.order" 37 | ~help:"" 38 | ~description:"Orders ingredients that will be shipped in 30 seconds" 39 | (fun args -> 40 | match args with 41 | | [ name ] -> 42 | Service.Queue.dispatch 43 | ~delay:(Sihl.Time.Span.minutes 2) 44 | name 45 | Job.order_ingredient 46 | |> Lwt.map Option.some 47 | | _ -> Lwt.return None) 48 | ;; 49 | 50 | let all = [ create_pizza; cook_pizza; order_ingredient ] 51 | -------------------------------------------------------------------------------- /docker/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam2:4.11 as builder 2 | WORKDIR app 3 | COPY pizza.opam . 4 | COPY dune-project . 5 | COPY .env . 6 | COPY app app 7 | COPY web web 8 | COPY run run 9 | COPY database database 10 | COPY public public 11 | COPY resources resources 12 | 13 | RUN sudo apt-get update -y && \ 14 | opam remote remove --all default && \ 15 | opam remote add default https://opam.ocaml.org && \ 16 | opam pin add -yn pizza . && \ 17 | OPAMSOLVERTIMEOUT=180 opam depext -y pizza && \ 18 | opam install --deps-only -y pizza && \ 19 | sudo chown -R opam:nogroup . 20 | 21 | RUN opam config exec -- dune build 22 | 23 | FROM debian:10 24 | WORKDIR /app 25 | 26 | COPY --from=builder /home/opam/opam-repository/app/_build/default/run/run.exe run.exe 27 | COPY --from=builder /home/opam/opam-repository/app/public public/ 28 | COPY --from=builder /home/opam/opam-repository/app/.env .env 29 | RUN mkdir logs 30 | 31 | RUN apt-get update -y && apt-get install -qq -yy sudo && \ 32 | sudo apt-get update -y && \ 33 | sudo apt-get install -qq -yy \ 34 | # Add the run-time dependencies here, as defined by "opam depext -ln" 35 | libev-dev \ 36 | libgmp-dev \ 37 | libpq-dev \ 38 | libssl-dev \ 39 | m4 \ 40 | perl \ 41 | pkg-config \ 42 | zlib1g-dev \ 43 | libpq-dev 44 | 45 | # WTF: https://github.com/mirage/ocaml-cohttp/issues/675 46 | RUN sudo bash -c 'echo "http 80/tcp www # WorldWideWeb HTTP" >> /etc/services' 47 | RUN sudo bash -c 'echo "https 443/tcp www # WorldWideWeb HTTPS" >> /etc/services' 48 | 49 | ENV SIHL_ENV production 50 | ENV ROOT_PATH /app 51 | CMD /app/run.exe start 52 | -------------------------------------------------------------------------------- /app/context/pizza/model.ml: -------------------------------------------------------------------------------- 1 | (* This defines our pizza model *) 2 | (* These models are pure and are used by other parts of the application, like 3 | the services *) 4 | 5 | (* We use some ppx for convenience *) 6 | (* make is used to construct a pizza model from data fetched from the database *) 7 | 8 | (* This creates a pizza model with a randomized id *) 9 | 10 | type ingredient = 11 | { name : string 12 | ; is_vegan : bool 13 | ; price : int 14 | ; created_at : Ptime.t 15 | ; updated_at : Ptime.t 16 | } 17 | [@@deriving show] 18 | 19 | let create_ingredient name is_vegan price = 20 | { name 21 | ; is_vegan 22 | ; price 23 | ; created_at = Ptime_clock.now () 24 | ; updated_at = Ptime_clock.now () 25 | } 26 | ;; 27 | 28 | let[@warning "-45"] ingredient_schema 29 | : (unit, string -> bool -> int -> ingredient, ingredient) Conformist.t 30 | = 31 | Conformist.( 32 | make 33 | Field. 34 | [ string 35 | ~validator:(fun name -> 36 | if String.length name > 12 37 | then Some "The name is too long, it has to be less than 12" 38 | else if String.equal "" name 39 | then Some "The name can not be empty" 40 | else None) 41 | "name" 42 | ; bool "is_vegan" 43 | ; int 44 | ~validator:(fun price -> 45 | if price >= 0 && price <= 10000 46 | then None 47 | else Some "Price has to be positive and less than 10'000") 48 | "price" 49 | ] 50 | create_ingredient) 51 | ;; 52 | 53 | type t = 54 | { name : string 55 | ; ingredients : string list 56 | ; created_at : Ptime.t 57 | ; updated_at : Ptime.t 58 | } 59 | 60 | let create_pizza name ingredients = 61 | { name 62 | ; ingredients 63 | ; created_at = Ptime_clock.now () 64 | ; updated_at = Ptime_clock.now () 65 | } 66 | ;; 67 | -------------------------------------------------------------------------------- /routes/routes.ml: -------------------------------------------------------------------------------- 1 | (* All the HTML HTTP entry points are listed in this file. 2 | 3 | Don't put actual logic here and keep the routes declarative and easy to read. 4 | The overall scope of the web app should be clear after scanning the 5 | routes. *) 6 | 7 | let global_middlewares = 8 | [ Sihl.Web.Middleware.id () 9 | ; Sihl.Web.Middleware.error () 10 | ; Sihl.Web.Middleware.static_file () 11 | ; Opium.Middleware.method_override 12 | ] 13 | ;; 14 | 15 | let site_middlewares = 16 | [ Opium.Middleware.content_length 17 | ; Sihl.Web.Middleware.csrf () 18 | ; Sihl.Web.Middleware.flash () 19 | ] 20 | ;; 21 | 22 | let site_public = 23 | Sihl.Web.choose 24 | ~middlewares:site_middlewares 25 | Sihl.Web. 26 | [ get "/" Handler.Welcome.index 27 | ; get "/login" Handler.Auth.login_index 28 | ; post "/login" Handler.Auth.login_create 29 | ; get "/logout" Handler.Auth.login_delete 30 | ; get "/registration" Handler.Auth.registration_index 31 | ; post "/registration" Handler.Auth.registration_create 32 | ] 33 | ;; 34 | 35 | let private_middlewares = 36 | List.concat [ site_middlewares; [ Middleware.Authn.middleware "/login" ] ] 37 | ;; 38 | 39 | let site_private = 40 | Sihl.Web.choose 41 | ~middlewares:private_middlewares 42 | (Sihl.Web.Rest.resource_of_service 43 | "ingredients" 44 | Pizza.ingredient_schema 45 | ~view: 46 | (module View.Ingredients : Sihl.Web.Rest.VIEW 47 | with type t = Pizza.ingredient) 48 | (module Pizza.Ingredient : Sihl.Web.Rest.SERVICE 49 | with type t = Pizza.ingredient)) 50 | ;; 51 | 52 | let router_admin_queue = 53 | Sihl.Web.choose 54 | ~middlewares:[ Middleware.Authn.middleware "/login" ] 55 | [ Service.Queue.router ~back:"/" "/admin/queue" ] 56 | ;; 57 | 58 | let api = Sihl.Web.choose ~scope:"/api" [] 59 | let all = Sihl.Web.choose [ site_public; site_private; api; router_admin_queue ] 60 | -------------------------------------------------------------------------------- /.devcontainer/devcontainer.json: -------------------------------------------------------------------------------- 1 | // For format details, see https://aka.ms/vscode-remote/devcontainer.json or the definition README at 2 | // https://github.com/microsoft/vscode-dev-containers/tree/master/containers/python-3 or the 3 | // devcontainer docu https://code.visualstudio.com/docs/remote/containers#_devcontainerjson-reference 4 | { 5 | "name": "pizza-demo", 6 | "dockerComposeFile": "./docker-compose.yml", 7 | "service": "dev", 8 | "runServices": [ 9 | "dev", 10 | "database", 11 | // "adminer" // uncomment if adminer should run to see the database 12 | ], 13 | "workspaceFolder": "/workspace", 14 | "remoteEnv": { 15 | "DATABASE_URL": "postgresql://admin:password@database:5432/dev", 16 | "VERSION": "dev", 17 | "OPAM_SWITCH_PREFIX": "/home/opam/.opam/4.11", 18 | "CAML_LD_LIBRARY_PATH": "/home/opam/.opam/4.11/lib/stublibs:/home/opam/.opam/4.11/lib/ocaml/stublibs:/home/opam/.opam/4.11/lib/ocaml", 19 | "OCAML_TOPLEVEL_PATH": "/home/opam/.opam/4.11/lib/toplevel", 20 | "MANPATH": ":/home/opam/.opam/4.11/man", 21 | "PATH": "/home/opam/.opam/4.11/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin", 22 | }, 23 | "postCreateCommand": "bash .devcontainer/postCreate.sh", 24 | // Use 'settings' to set *default* container specific settings.json values on container create. 25 | // You can edit these settings after create using File > Preferences > Settings > Remote. 26 | "settings": { 27 | "terminal.integrated.shell.linux": "/bin/zsh", 28 | "editor.formatOnSave": true, 29 | "files.associations": { 30 | "*.ml": "ocaml", 31 | "*.mli": "ocaml", 32 | }, 33 | "ocaml.sandbox": { 34 | "kind": "global" 35 | } 36 | }, 37 | // Add the IDs of extensions you want installed when the container is created in the array below. 38 | "extensions": [ 39 | "donjayamanne.githistory", 40 | "eamodio.gitlens", 41 | "hackwaly.ocaml-debugger", 42 | "ocamllabs.ocaml-platform", 43 | ], 44 | } 45 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing 2 | 3 | ## Setup your development environment 4 | 5 | You need Opam, you can install it by following [Opam's documentation](https://opam.ocaml.org/doc/Install.html). 6 | 7 | With Opam installed, you can install the dependencies in a new local switch with: 8 | 9 | ```bash 10 | make switch 11 | ``` 12 | 13 | Or globally, with: 14 | 15 | ```bash 16 | make deps 17 | ``` 18 | 19 | Then, build the project with: 20 | 21 | ```bash 22 | make build 23 | ``` 24 | 25 | ### Running Binary 26 | 27 | After building the project, you can run the main binary that is produced. 28 | 29 | ```bash 30 | make start 31 | ``` 32 | 33 | ### Running Tests 34 | 35 | You can run the test compiled executable: 36 | 37 | ```bash 38 | make test 39 | ``` 40 | 41 | ### Building documentation 42 | 43 | Documentation for the libraries in the project can be generated with: 44 | 45 | ```bash 46 | make doc 47 | open-cli $(make doc-path) 48 | ``` 49 | 50 | This assumes you have a command like [open-cli](https://github.com/sindresorhus/open-cli) installed on your system. 51 | 52 | > NOTE: On macOS, you can use the system command `open`, for instance `open $(make doc-path)` 53 | 54 | ### Repository Structure 55 | 56 | The following snippet describes pizza's repository structure. 57 | 58 | ```text 59 | . 60 | ├── bin/ 61 | | Source for pizza's binary. This links to the library defined in `lib/`. 62 | │ 63 | ├── lib/ 64 | | Source for pizza's library. Contains pizza's core functionnalities. 65 | │ 66 | ├── test/ 67 | | Unit tests and integration tests for pizza. 68 | │ 69 | ├── dune-project 70 | | Dune file used to mark the root of the project and define project-wide parameters. 71 | | For the documentation of the syntax, see https://dune.readthedocs.io/en/stable/dune-files.html#dune-project 72 | │ 73 | ├── LICENSE 74 | │ 75 | ├── Makefile 76 | | Make file containing common development command. 77 | │ 78 | ├── README.md 79 | │ 80 | └── pizza.opam 81 | Opam package definition. 82 | To know more about creating and publishing opam packages, see https://opam.ocaml.org/doc/Packaging.html. 83 | ``` 84 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: [push, pull_request] 4 | 5 | 6 | jobs: 7 | build: 8 | name: Build and test 9 | runs-on: ${{ matrix.os }} 10 | services: 11 | postgres: 12 | image: postgres:12.2 13 | env: 14 | POSTGRES_USER: admin 15 | POSTGRES_PASSWORD: password 16 | POSTGRES_DB: dev 17 | ports: 18 | - 5432:5432 19 | strategy: 20 | fail-fast: false 21 | matrix: 22 | os: 23 | - ubuntu-latest 24 | ocaml-version: 25 | - 4.11.1 26 | 27 | steps: 28 | - name: Checkout code 29 | uses: actions/checkout@v2 30 | 31 | - name: Retrieve opam cache 32 | uses: actions/cache@v2 33 | if: runner.os != 'Windows' 34 | id: cache-opam 35 | with: 36 | path: ~/.opam 37 | key: v1-${{ runner.os }}-opam-${{ matrix.ocaml-version }}-${{ hashFiles('pizza.opam.locked') }} 38 | restore-keys: | 39 | v1-${{ runner.os }}-opam-${{ matrix.ocaml-version }}- 40 | 41 | - name: Use OCaml ${{ matrix.ocaml-version }} 42 | uses: avsm/setup-ocaml@v1 43 | with: 44 | ocaml-version: ${{ matrix.ocaml-version }} 45 | 46 | - name: Update opam repository 47 | if: steps.cache-opam.outputs.cache-hit != 'true' 48 | run: opam update 49 | 50 | - name: Pin package 51 | run: opam pin add pizza.dev . --no-action 52 | 53 | - name: Query and install external dependencies 54 | run: opam depext pizza --yes --with-doc 55 | 56 | - name: Install dependencies 57 | if: steps.cache-opam.outputs.cache-hit != 'true' 58 | run: | 59 | opam install . --deps-only --with-doc --with-test --locked --unlock-base 60 | opam install ocamlformat --skip-updates 61 | 62 | - name: Upgrade dependencies 63 | run: opam upgrade --fixup 64 | if: steps.cache-opam.outputs.cache-hit == 'true' 65 | 66 | - name: Build 67 | run: make build 68 | 69 | - name: Check formatting 70 | run: make format 71 | 72 | - name: Run tests 73 | run: make test 74 | 75 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .DEFAULT_GOAL := all 2 | 3 | ARGS := $(wordlist 2,$(words $(MAKECMDGOALS)),$(MAKECMDGOALS)) 4 | ARGS := $(subst :,\:,$(ARGS)) 5 | $(eval $(ARGS):;@:) 6 | 7 | SHELL=bash 8 | 9 | .PHONY: all 10 | all: 11 | opam exec -- dune build --root . @install 12 | 13 | .PHONY: deps 14 | deps: ## Install development dependencies 15 | opam install -y dune-release merlin ocamlformat utop ocaml-lsp-server 16 | OPAMSOLVERTIMEOUT=240 opam install --deps-only --with-test --with-doc -y . 17 | 18 | .PHONY: create_switch 19 | create_switch: 20 | opam switch create . ocaml-base-compiler.4.11.0 --no-install --locked 21 | 22 | .PHONY: switch 23 | switch: create_switch deps ## Create an opam switch and install development dependencies 24 | 25 | .PHONY: lock 26 | lock: ## Generate a lock file 27 | opam lock -y . 28 | 29 | .PHONY: build 30 | build: ## Build the project, including non installable libraries and executables 31 | opam exec -- dune build --root . 32 | 33 | .PHONY: install 34 | install: all ## Install the packages on the system 35 | opam exec -- dune install --root . 36 | 37 | .PHONY: sihl 38 | sihl: all ## Run the produced executable 39 | SIHL_ENV=development opam exec -- dune exec --root . run/run.exe $(ARGS) 40 | 41 | .PHONY: test 42 | test: ## Run the all tests 43 | SIHL_ENV=test opam exec -- dune build --root . @runtest 44 | 45 | .PHONY: clean 46 | clean: ## Clean build artifacts and other generated files 47 | opam exec -- dune clean --root . 48 | 49 | .PHONY: doc 50 | doc: ## Generate odoc documentation 51 | opam exec -- dune build --root . @doc 52 | 53 | .PHONY: format 54 | format: ## Format the codebase with ocamlformat 55 | opam exec -- dune build --root . --auto-promote @fmt 56 | 57 | .PHONE dev: 58 | .SILENT: 59 | .ONESHELL: 60 | dev: ## Run the Sihl app, watch files and restart on change 61 | sigint_handler() 62 | { 63 | kill -9 $$(lsof -ti tcp:3000) 64 | exit 65 | } 66 | trap sigint_handler SIGINT 67 | while true; do 68 | dune build 69 | if [ $$? -eq 0 ] 70 | then 71 | SIHL_ENV=development ./_build/default/run/run.exe server & 72 | fi 73 | echo 74 | inotifywait -e modify -e move -e create -e delete -e attrib -r `pwd` --exclude "(_build|logs|Makefile|.devcontainer|.git)" -qq 75 | kill -9 $$(lsof -ti tcp:3000) 76 | echo 77 | done 78 | 79 | .PHONY: utop 80 | utop: ## Run a REPL and link with the project's libraries 81 | opam exec -- dune utop --root . lib -- -implicit-bindings 82 | 83 | 84 | .PHONY: db 85 | db: ## Starts the database using docker-compose 86 | docker-compose -f docker/docker-compose.dev.yml up -d 87 | 88 | .PHONY: db_down 89 | db_down: ## Removes the database using docker-compose 90 | docker-compose -f docker/docker-compose.dev.yml down 91 | 92 | -------------------------------------------------------------------------------- /web/handler/auth.ml: -------------------------------------------------------------------------------- 1 | let login_index req = 2 | let open Lwt.Syntax in 3 | let* user = Service.User.Web.user_from_session req in 4 | match user with 5 | | Some _ -> Sihl.Web.Response.redirect_to "/ingredients" |> Lwt.return 6 | | None -> 7 | let csrf = Sihl.Web.Csrf.find req |> Option.get in 8 | let alert = Sihl.Web.Flash.find_alert req in 9 | Lwt.return @@ Sihl.Web.Response.of_html (View.Auth.login ~alert csrf) 10 | ;; 11 | 12 | let login_create req = 13 | let open Lwt.Syntax in 14 | let* urlencoded = Sihl.Web.Request.to_urlencoded req in 15 | match urlencoded with 16 | | [ ("_csrf", _); ("email", [ email ]); ("password", [ password ]) ] -> 17 | let* user = Service.User.login email ~password in 18 | (match user with 19 | | Ok user -> 20 | Sihl.Web.Response.redirect_to "/ingredients" 21 | |> Sihl.Web.Session.set [ "user_id", user.Sihl.Contract.User.id ] 22 | |> Lwt.return 23 | | Error _ -> 24 | Sihl.Web.Response.redirect_to "/login" 25 | |> Sihl.Web.Flash.set_alert "Invalid email or password provided" 26 | |> Lwt.return) 27 | | _ -> 28 | Sihl.Web.Response.redirect_to "/login" 29 | |> Sihl.Web.Flash.set_alert "Invalid input provided" 30 | |> Lwt.return 31 | ;; 32 | 33 | let login_delete _ = 34 | Sihl.Web.Response.redirect_to "/" |> Sihl.Web.Session.set [] |> Lwt.return 35 | ;; 36 | 37 | let registration_index req = 38 | let open Lwt.Syntax in 39 | let* user = Service.User.Web.user_from_session req in 40 | match user with 41 | | Some _ -> Sihl.Web.Response.redirect_to "/ingredients" |> Lwt.return 42 | | None -> 43 | let csrf = Sihl.Web.Csrf.find req |> Option.get in 44 | let alert = Sihl.Web.Flash.find_alert req in 45 | Lwt.return @@ Sihl.Web.Response.of_html (View.Auth.registration ~alert csrf) 46 | ;; 47 | 48 | let registration_create req = 49 | let open Lwt.Syntax in 50 | let* urlencoded = Sihl.Web.Request.to_urlencoded req in 51 | match urlencoded with 52 | | [ ("_csrf", _) 53 | ; ("email", [ email ]) 54 | ; ("password", [ password ]) 55 | ; ("password_confirmation", [ password_confirmation ]) 56 | ] -> 57 | let* user = 58 | Service.User.register_user email ~password ~password_confirmation 59 | in 60 | (match user with 61 | | Ok user -> 62 | Sihl.Web.Response.redirect_to "/ingredients" 63 | |> Sihl.Web.Session.set [ "user_id", user.Sihl.Contract.User.id ] 64 | |> Lwt.return 65 | | Error _ -> 66 | Sihl.Web.Response.redirect_to "/registration" 67 | |> Sihl.Web.Flash.set_alert "Invalid email or password provided" 68 | |> Lwt.return) 69 | | _ -> 70 | Sihl.Web.Response.redirect_to "/registration" 71 | |> Sihl.Web.Flash.set_alert "Invalid input provided" 72 | |> Lwt.return 73 | ;; 74 | -------------------------------------------------------------------------------- /app/context/pizza/pizza.ml: -------------------------------------------------------------------------------- 1 | include Model 2 | 3 | exception Exception of string 4 | 5 | let clean = 6 | if Sihl.Configuration.is_production () 7 | then 8 | raise 9 | @@ Exception 10 | "Can not clean repository in production, this is most likely not what \ 11 | you want" 12 | else Repo.clean 13 | ;; 14 | 15 | module Ingredient = struct 16 | type t = ingredient 17 | 18 | let find name = Repo.find_ingredient name 19 | 20 | let search ?filter:_ ?sort:_ ?limit:_ ?offset:_ () = 21 | Repo.find_ingredients () |> Lwt.map (fun v -> v, 0) 22 | ;; 23 | 24 | let insert (ingredient : ingredient) = 25 | let open Lwt.Syntax in 26 | let* found = find ingredient.name in 27 | match found with 28 | | None -> 29 | let* () = Repo.insert_ingredient ingredient in 30 | let* inserted = Repo.find_ingredient ingredient.name in 31 | (match inserted with 32 | | Some ingredient -> Lwt.return (Ok ingredient) 33 | | None -> 34 | Logs.err (fun m -> 35 | m "Failed to insert ingredient '%a'" pp_ingredient ingredient); 36 | Lwt.return @@ Error "Failed to insert ingredient") 37 | | Some _ -> 38 | Lwt.return 39 | @@ Error (Format.sprintf "Ingredient '%s' already exists" ingredient.name) 40 | ;; 41 | 42 | let create name is_vegan price : (ingredient, string) Result.t Lwt.t = 43 | let open Lwt.Syntax in 44 | let* ingredient = find name in 45 | match ingredient with 46 | | None -> 47 | let ingredient = create_ingredient name is_vegan price in 48 | insert ingredient 49 | | Some ingredient -> 50 | Lwt.return 51 | (Error (Format.sprintf "Ingredient '%s' already exists" ingredient.name)) 52 | ;; 53 | 54 | let update _ (ingredient : ingredient) = 55 | let open Lwt.Syntax in 56 | let* () = Repo.update_ingredient ingredient in 57 | let* updated = Repo.find_ingredient ingredient.name in 58 | match updated with 59 | | Some updated -> Lwt.return (Ok updated) 60 | | None -> Lwt.return @@ Error "Failed to update ingredient" 61 | ;; 62 | 63 | let delete (ingredient : ingredient) = 64 | Repo.delete_ingredient ingredient |> Lwt.map Result.ok 65 | ;; 66 | end 67 | 68 | let add_ingredient_to_pizza (pizza : string) (ingredient : ingredient) = 69 | Repo.add_ingredient_to_pizza pizza ingredient.name 70 | ;; 71 | 72 | let create_pizza name (ingredients : string list) : t Lwt.t = 73 | let open Lwt.Syntax in 74 | let pizza = Model.create_pizza name ingredients in 75 | let* () = Repo.insert_pizza pizza ingredients in 76 | let* pizza = Repo.find_pizza name in 77 | match pizza with 78 | | Some pizza -> Lwt.return pizza 79 | | None -> 80 | Logs.err (fun m -> m "Failed to create pizza '%s'" name); 81 | raise @@ Exception "Failed to create pizza" 82 | ;; 83 | 84 | let find_pizza name = Repo.find_pizza name 85 | let find_pizzas = Repo.find_pizzas 86 | let delete_pizza (pizza : t) : unit Lwt.t = Repo.delete_pizza pizza 87 | -------------------------------------------------------------------------------- /database/pizza.ml: -------------------------------------------------------------------------------- 1 | (* Put your database migrations here. *) 2 | 3 | let create_pizzas_table = 4 | Sihl.Database.Migration.create_step 5 | ~label:"create pizzas table" 6 | {sql| 7 | CREATE TABLE IF NOT EXISTS pizzas ( 8 | id serial, 9 | name VARCHAR(128) NOT NULL, 10 | created_at TIMESTAMP DEFAULT CURRENT_TIMESTAMP, 11 | updated_at TIMESTAMP DEFAULT CURRENT_TIMESTAMP, 12 | PRIMARY KEY (id), 13 | UNIQUE (name) 14 | ); 15 | |sql} 16 | ;; 17 | 18 | let create_ingredients_table = 19 | Sihl.Database.Migration.create_step 20 | ~label:"create ingredients table" 21 | {sql| 22 | CREATE TABLE IF NOT EXISTS ingredients ( 23 | id serial, 24 | name VARCHAR(128) NOT NULL, 25 | created_at TIMESTAMP DEFAULT CURRENT_TIMESTAMP, 26 | updated_at TIMESTAMP DEFAULT CURRENT_TIMESTAMP, 27 | PRIMARY KEY (id), 28 | UNIQUE (name) 29 | ); 30 | |sql} 31 | ;; 32 | 33 | let create_pizzas_ingredients_table = 34 | Sihl.Database.Migration.create_step 35 | ~label:"create pizzas_ingredients table" 36 | {sql| 37 | CREATE TABLE IF NOT EXISTS pizzas_ingredients ( 38 | pizza_id INTEGER NOT NULL, 39 | ingredient_id INTEGER NOT NULL, 40 | created_at TIMESTAMP DEFAULT CURRENT_TIMESTAMP, 41 | updated_at TIMESTAMP DEFAULT CURRENT_TIMESTAMP, 42 | UNIQUE (pizza_id, ingredient_id), 43 | CONSTRAINT fk_pizza 44 | FOREIGN KEY (pizza_id) REFERENCES pizzas (id) 45 | ON DELETE CASCADE, 46 | CONSTRAINT fk_ingredient 47 | FOREIGN KEY (ingredient_id) REFERENCES ingredients (id) 48 | ); 49 | |sql} 50 | ;; 51 | 52 | let add_vegan_flag_and_price = 53 | Sihl.Database.Migration.create_step 54 | ~label:"add vegan flag and price" 55 | {sql| 56 | ALTER TABLE ingredients 57 | ADD COLUMN is_vegan BOOL NOT NULL DEFAULT false, 58 | ADD COLUMN price INT NOT NULL DEFAULT 0; 59 | |sql} 60 | ;; 61 | 62 | let remove_timezone_pizzas_table = 63 | Sihl.Database.Migration.create_step 64 | ~label:"remove timezone information from pizzas" 65 | {sql| 66 | ALTER TABLE pizzas 67 | ALTER COLUMN created_at TYPE TIMESTAMP, 68 | ALTER COLUMN updated_at TYPE TIMESTAMP; 69 | |sql} 70 | ;; 71 | 72 | let remove_timezone_ingredients_table = 73 | Sihl.Database.Migration.create_step 74 | ~label:"remove timezone information from ingredients" 75 | {sql| 76 | ALTER TABLE ingredients 77 | ALTER COLUMN created_at TYPE TIMESTAMP, 78 | ALTER COLUMN updated_at TYPE TIMESTAMP; 79 | |sql} 80 | ;; 81 | 82 | let remove_timezone_pizzas_ingredients_table = 83 | Sihl.Database.Migration.create_step 84 | ~label:"remove timezone information from pizzas_ingredients" 85 | {sql| 86 | ALTER TABLE pizzas_ingredients 87 | ALTER COLUMN created_at TYPE TIMESTAMP, 88 | ALTER COLUMN updated_at TYPE TIMESTAMP; 89 | |sql} 90 | ;; 91 | 92 | let migration = 93 | Sihl.Database.Migration.( 94 | empty "pizzas" 95 | |> add_step create_pizzas_table 96 | |> add_step create_ingredients_table 97 | |> add_step create_pizzas_ingredients_table 98 | |> add_step add_vegan_flag_and_price 99 | |> add_step remove_timezone_pizzas_table 100 | |> add_step remove_timezone_ingredients_table 101 | |> add_step remove_timezone_pizzas_ingredients_table) 102 | ;; 103 | -------------------------------------------------------------------------------- /pizza.opam.locked: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | synopsis: "A restaurant serving Pizza and sometimes Lasagna" 3 | description: """ 4 | A restaurant serving Pizza and sometimes Lasagna 5 | """ 6 | maintainer: ["Josef Erben"] 7 | authors: ["Josef Erben"] 8 | license: "MIT" 9 | homepage: "https://github.com/oxidizing/pizza" 10 | doc: "https://oxidizing.github.io/pizza/" 11 | bug-reports: "https://github.com/oxidizing/pizza/issues" 12 | depends: [ 13 | "angstrom" {= "0.15.0"} 14 | "asn1-combinators" {= "0.2.5"} 15 | "astring" {= "0.8.5"} 16 | "base" {= "v0.14.1"} 17 | "base-bytes" {= "base"} 18 | "base-threads" {= "base"} 19 | "base-unix" {= "base"} 20 | "base64" {= "3.5.0"} 21 | "bigarray-compat" {= "1.0.0"} 22 | "bigstringaf" {= "0.7.0"} 23 | "biniou" {= "1.2.1"} 24 | "caqti" {= "1.5.0"} 25 | "caqti-driver-postgresql" {= "1.5.0"} 26 | "caqti-lwt" {= "1.3.0"} 27 | "cmdliner" {= "1.0.4"} 28 | "conf-gmp" {= "3"} 29 | "conf-gmp-powm-sec" {= "3"} 30 | "conf-libev" {= "4-11"} 31 | "conf-libssl" {= "3"} 32 | "conf-pkg-config" {= "2"} 33 | "conf-postgresql" {= "1"} 34 | "conf-zlib" {= "1"} 35 | "conformist" {= "0.5.0"} 36 | "containers" {= "3.3"} 37 | "cppo" {= "1.6.7"} 38 | "cryptokit" {= "1.16.1"} 39 | "csexp" {= "1.5.1"} 40 | "cstruct" {= "5.2.0"} 41 | "cstruct-sexp" {= "5.2.0"} 42 | "domain-name" {= "0.3.0"} 43 | "dune" {= "2.8.5"} 44 | "dune-build-info" {= "2.8.5"} 45 | "dune-configurator" {= "2.8.5"} 46 | "duration" {= "0.1.3"} 47 | "easy-format" {= "1.3.2"} 48 | "eqaf" {= "0.7"} 49 | "faraday" {= "0.7.2"} 50 | "faraday-lwt" {= "0.7.2"} 51 | "faraday-lwt-unix" {= "0.7.2"} 52 | "fiat-p256" {= "0.2.3"} 53 | "fieldslib" {= "v0.14.0"} 54 | "fmt" {= "0.8.9"} 55 | "gmap" {= "0.3.0"} 56 | "hacl_x25519" {= "0.2.2"} 57 | "hex" {= "1.4.0"} 58 | "hkdf" {= "1.0.4"} 59 | "hmap" {= "0.8.1"} 60 | "httpaf" {= "0.7.1"} 61 | "httpaf-lwt-unix" {= "0.7.1"} 62 | "jwto" {= "0.3.0"} 63 | "logs" {= "0.7.0"} 64 | "lwt" {= "5.4.0"} 65 | "lwt_ppx" {= "2.0.1"} 66 | "lwt_ssl" {= "1.1.3"} 67 | "magic-mime" {= "1.1.3"} 68 | "markup" {= "1.0.0-1"} 69 | "mirage-crypto" {= "0.9.1"} 70 | "mirage-crypto-pk" {= "0.9.1"} 71 | "mirage-crypto-rng" {= "0.9.1"} 72 | "mirage-no-solo5" {= "1"} 73 | "mirage-no-xen" {= "1"} 74 | "mmap" {= "1.1.0"} 75 | "mtime" {= "1.2.0"} 76 | "multipart-form-data" {= "0.3.0"} 77 | "num" {= "1.4"} 78 | "ocaml" {= "4.11.2"} 79 | "ocaml-compiler-libs" {= "v0.12.3"} 80 | "ocaml-migrate-parsetree" {= "1.8.0"} 81 | "ocaml-syntax-shims" {= "1.0.0"} 82 | "ocamlbuild" {= "0.14.0"} 83 | "ocamlfind" {= "1.9.1"} 84 | "ocplib-endian" {= "1.1"} 85 | "opium" {= "0.20.0"} 86 | "parsexp" {= "v0.14.0"} 87 | "postgresql" {= "5.0.0"} 88 | "ppx_cstruct" {= "5.2.0"} 89 | "ppx_derivers" {= "1.2.1"} 90 | "ppx_deriving" {= "5.1"} 91 | "ppx_deriving_yojson" {= "3.6.1"} 92 | "ppx_fields_conv" {= "v0.14.1"} 93 | "ppx_sexp_conv" {= "v0.14.1"} 94 | "ppx_tools_versioned" {= "5.4.0"} 95 | "ppxlib" {= "0.15.0"} 96 | "ptime" {= "0.8.5"} 97 | "re" {= "1.9.0"} 98 | "result" {= "1.5"} 99 | "rock" {= "0.20.0"} 100 | "rresult" {= "0.6.0"} 101 | "safepass" {= "3.1"} 102 | "seq" {= "base"} 103 | "sexplib" {= "v0.14.0"} 104 | "sexplib0" {= "v0.14.0"} 105 | "sihl" {= "0.6.0~rc1"} 106 | "sihl-queue" {= "0.6.0~rc1"} 107 | "sihl-user" {= "0.6.0~rc1"} 108 | "ssl" {= "0.5.10"} 109 | "stdlib-shims" {= "0.3.0"} 110 | "stringext" {= "1.6.0"} 111 | "tls" {= "0.12.8"} 112 | "topkg" {= "1.0.3"} 113 | "tsort" {= "2.0.0"} 114 | "tyxml" {= "4.4.0"} 115 | "tyxml-ppx" {= "4.4.0"} 116 | "tyxml-syntax" {= "4.4.0"} 117 | "uchar" {= "0.0.2"} 118 | "uri" {= "4.1.0"} 119 | "uuidm" {= "0.9.7"} 120 | "uutf" {= "1.0.2"} 121 | "x509" {= "0.11.2"} 122 | "yojson" {= "1.7.0"} 123 | "zarith" {= "1.12"} 124 | ] 125 | build: [ 126 | ["dune" "subst"] {pinned} 127 | [ 128 | "dune" 129 | "build" 130 | "-p" 131 | name 132 | "-j" 133 | jobs 134 | "@install" 135 | "@runtest" {with-test} 136 | "@doc" {with-doc} 137 | ] 138 | ] 139 | dev-repo: "git+https://github.com/oxidizing/pizza.git" 140 | name: "pizza" 141 | version: "dev" 142 | -------------------------------------------------------------------------------- /test/pizza/test.ml: -------------------------------------------------------------------------------- 1 | open Lwt.Syntax 2 | 3 | let create_ingredient _ () = 4 | let* () = Sihl.Cleaner.clean_all () in 5 | let* () = Pizza.clean () in 6 | let* _ = Pizza.Ingredient.create "ham" true 10 in 7 | let* _ = Pizza.Ingredient.create "tomato" true 2 in 8 | let* (ham : Pizza.ingredient) = 9 | Pizza.Ingredient.find "ham" |> Lwt.map Option.get 10 | in 11 | let* (tomato : Pizza.ingredient) = 12 | Pizza.Ingredient.find "tomato" |> Lwt.map Option.get 13 | in 14 | Alcotest.(check string "has ham" "ham" ham.Pizza.name); 15 | Alcotest.(check string "has tomato" "tomato" tomato.Pizza.name); 16 | Lwt.return () 17 | ;; 18 | 19 | let delete_ingredient _ () = 20 | let* () = Sihl.Cleaner.clean_all () in 21 | let* () = Pizza.clean () in 22 | let* _ = Pizza.Ingredient.create "ham" true 10 in 23 | let* (ham : Pizza.ingredient) = 24 | Pizza.Ingredient.find "ham" |> Lwt.map Option.get 25 | in 26 | Alcotest.(check string "has ham" "ham" ham.Pizza.name); 27 | let* _ = Pizza.Ingredient.delete ham in 28 | let* ham = Pizza.Ingredient.find "ham" in 29 | Alcotest.(check bool "has deleted ham" true (Option.is_none ham)); 30 | Lwt.return () 31 | ;; 32 | 33 | let find_ingredients _ () = 34 | let* () = Sihl.Cleaner.clean_all () in 35 | let* () = Pizza.clean () in 36 | let* _ = Pizza.Ingredient.create "ham" true 4 in 37 | let* _ = Pizza.Ingredient.create "tomato" true 2 in 38 | let* (ingredients : string list) = 39 | Pizza.Ingredient.search () 40 | |> Lwt.map fst 41 | |> Lwt.map 42 | (List.map ~f:(fun (ingredient : Pizza.ingredient) -> 43 | ingredient.Pizza.name)) 44 | in 45 | Alcotest.(check (list string) "has pizza" [ "tomato"; "ham" ] ingredients); 46 | Lwt.return () 47 | ;; 48 | 49 | let create_pizza_without_ingredients _ () = 50 | let* () = Sihl.Cleaner.clean_all () in 51 | let* () = Pizza.clean () in 52 | let* _ = Pizza.create_pizza "boring" [] in 53 | let* (pizza : Pizza.t) = Pizza.find_pizza "boring" |> Lwt.map Option.get in 54 | Alcotest.(check string "created boring pizza" "boring" pizza.Pizza.name); 55 | Lwt.return () 56 | ;; 57 | 58 | let create_pizza_with_ingredients _ () = 59 | let* () = Sihl.Cleaner.clean_all () in 60 | let* () = Pizza.clean () in 61 | let* _ = Pizza.create_pizza "prosciutto" [ "ham"; "tomato" ] in 62 | let* (pizza : Pizza.t) = 63 | Pizza.find_pizza "prosciutto" |> Lwt.map Option.get 64 | in 65 | Alcotest.(check string "created prosciutto" "prosciutto" pizza.Pizza.name); 66 | Alcotest.( 67 | check 68 | (list string) 69 | "has ingredients" 70 | [ "ham"; "tomato" ] 71 | pizza.Pizza.ingredients); 72 | let* (ham : Pizza.ingredient) = 73 | Pizza.Ingredient.find "ham" |> Lwt.map Option.get 74 | in 75 | Alcotest.(check string "has created ingredient" "ham" ham.Pizza.name); 76 | Lwt.return () 77 | ;; 78 | 79 | let delete_pizza_with_ingredients _ () = 80 | let* () = Sihl.Cleaner.clean_all () in 81 | let* () = Pizza.clean () in 82 | let* _ = Pizza.create_pizza "prosciutto" [ "ham"; "tomato" ] in 83 | let* (pizza : Pizza.t) = 84 | Pizza.find_pizza "prosciutto" |> Lwt.map Option.get 85 | in 86 | Alcotest.(check string "created prosciutto" "prosciutto" pizza.Pizza.name); 87 | let* () = Pizza.delete_pizza pizza in 88 | let* pizza = Pizza.find_pizza "prosciutto" in 89 | Alcotest.(check bool "has deleted pizza" true (Option.is_none pizza)); 90 | let* (ham : Pizza.ingredient) = 91 | Pizza.Ingredient.find "ham" |> Lwt.map Option.get 92 | in 93 | Alcotest.(check string "has not deleted ingredient" "ham" ham.Pizza.name); 94 | let* (tomato : Pizza.ingredient) = 95 | Pizza.Ingredient.find "tomato" |> Lwt.map Option.get 96 | in 97 | Alcotest.( 98 | check string "has not deleted ingredient" "tomato" tomato.Pizza.name); 99 | Lwt.return () 100 | ;; 101 | 102 | let find_pizzas _ () = 103 | let* () = Sihl.Cleaner.clean_all () in 104 | let* () = Pizza.clean () in 105 | let* _ = Pizza.create_pizza "boring" [] in 106 | let* _ = Pizza.create_pizza "proscioutto" [ "ham"; "tomato" ] in 107 | let* (ingredients : string list) = 108 | Pizza.Ingredient.search () 109 | |> Lwt.map fst 110 | |> Lwt.map 111 | (List.map ~f:(fun (ingredient : Pizza.ingredient) -> 112 | ingredient.Pizza.name)) 113 | in 114 | Alcotest.(check (list string) "has pizza" [ "tomato"; "ham" ] ingredients); 115 | Lwt.return () 116 | ;; 117 | 118 | let suite = 119 | Alcotest_lwt. 120 | [ ( "delicious test suite" 121 | , [ test_case "create ingredient" `Quick create_ingredient 122 | ; test_case "delete ingredient" `Quick delete_ingredient 123 | ; test_case "find ingredients" `Quick find_ingredients 124 | ; test_case 125 | "create pizza without ingredients" 126 | `Quick 127 | create_pizza_without_ingredients 128 | ; test_case 129 | "create pizza with ingredients" 130 | `Quick 131 | create_pizza_with_ingredients 132 | ; test_case 133 | "delete pizza with ingredients" 134 | `Quick 135 | delete_pizza_with_ingredients 136 | ; test_case "find pizzas" `Quick find_pizzas 137 | ] ) 138 | ] 139 | ;; 140 | 141 | let services = 142 | [ Sihl.Database.register () 143 | ; Sihl.Database.Migration.PostgreSql.register [ Database.Pizza.migration ] 144 | ] 145 | ;; 146 | 147 | let () = 148 | let open Lwt.Syntax in 149 | Sihl.Configuration.read_string "DATABASE_URL" 150 | |> Option.value ~default:"postgres://admin:password@127.0.0.1:5432/dev" 151 | |> Unix.putenv "DATABASE_URL"; 152 | Logs.set_level (Sihl.Log.get_log_level ()); 153 | Logs.set_reporter (Sihl.Log.cli_reporter ()); 154 | Lwt_main.run 155 | (let* _ = Sihl.Container.start_services services in 156 | Alcotest_lwt.run "tests" suite) 157 | ;; 158 | -------------------------------------------------------------------------------- /web/view/ingredients.ml: -------------------------------------------------------------------------------- 1 | open Tyxml 2 | 3 | type t = Pizza.ingredient 4 | 5 | let skip_index_fetch = false 6 | 7 | let%html delete_button (ingredient : Pizza.ingredient) csrf = 8 | {| 9 |
12 | 15 | 16 | 17 |
18 | |} 19 | ;; 20 | 21 | let list_header = 22 | [%html 23 | {|NamePriceVeganUpdate atCreated at|}] 24 | ;; 25 | 26 | let create_link = [%html {||}] 27 | 28 | let edit_link name = 29 | [%html 30 | {|Edit|}] 31 | ;; 32 | 33 | let alert_message alert = 34 | [%html 35 | {||} 36 | [ Html.txt (Option.value alert ~default:"") ] 37 | {||}] 38 | ;; 39 | 40 | let notice_message notice = 41 | [%html 42 | {||} 43 | [ Html.txt (Option.value notice ~default:"") ] 44 | {||}] 45 | ;; 46 | 47 | let index 48 | req 49 | csrf 50 | (result : Pizza.ingredient list * int) 51 | (_ : Sihl.Web.Rest.query) 52 | = 53 | let open Lwt.Syntax in 54 | let ingredients, _ = result in 55 | let* user = Service.User.Web.user_from_session req |> Lwt.map Option.get in 56 | let notice = Sihl.Web.Flash.find_notice req in 57 | let alert = Sihl.Web.Flash.find_alert req in 58 | let list_items = 59 | List.map 60 | ~f:(fun (ingredient : Pizza.ingredient) -> 61 | [%html 62 | {||} 65 | [ Html.txt ingredient.Pizza.name ] 66 | {||} 67 | [ Html.txt (string_of_int ingredient.Pizza.price) ] 68 | {||} 69 | [ Html.txt (string_of_bool ingredient.Pizza.is_vegan) ] 70 | {||} 71 | [ Html.txt (Ptime.to_rfc3339 ingredient.Pizza.created_at) ] 72 | {||} 73 | [ Html.txt (Ptime.to_rfc3339 ingredient.Pizza.updated_at) ] 74 | {||} 75 | [ delete_button ingredient csrf ] 76 | [ edit_link ingredient.Pizza.name ] 77 | {||}]) 78 | ingredients 79 | in 80 | let ingredients = 81 | [%html 82 | {|
Ingredients|} 83 | (List.cons list_header list_items) 84 | {|
|}] 85 | in 86 | Lwt.return 87 | @@ Layout.page 88 | (Some user) 89 | [ alert_message alert; notice_message notice; create_link; ingredients ] 90 | ;; 91 | 92 | let new' req csrf (form : Sihl.Web.Rest.form) = 93 | let open Lwt.Syntax in 94 | let notice = Sihl.Web.Flash.find_notice req in 95 | let alert = Sihl.Web.Flash.find_alert req in 96 | let* user = Service.User.Web.user_from_session req |> Lwt.map Option.get in 97 | let name_value, name_error = Sihl.Web.Rest.find_form "name" form in 98 | let vegan_value, _ = Sihl.Web.Rest.find_form "is_vegan" form in 99 | let price_value, price_error = Sihl.Web.Rest.find_form "price" form in 100 | let checkbox = 101 | if Option.bind vegan_value bool_of_string_opt |> Option.value ~default:false 102 | then 103 | [%html {||}] 104 | else [%html {||}] 105 | in 106 | let form = 107 | [%html 108 | {| 109 |
110 | 113 |
114 | Name 115 | 118 |
119 |

|} 120 | [ Html.txt (Option.value ~default:"" name_error) ] 121 | {|

122 |
123 | |} 124 | [ checkbox ] 125 | {| 126 | 127 |
128 |
129 | 130 | 133 |
134 |

|} 135 | [ Html.txt (Option.value ~default:"" price_error) ] 136 | {|

137 |
138 | 139 |
140 |
141 | |}] 142 | in 143 | Lwt.return 144 | @@ Layout.page 145 | (Some user) 146 | [ alert_message alert; notice_message notice; form ] 147 | ;; 148 | 149 | let show req (ingredient : Pizza.ingredient) = 150 | let open Lwt.Syntax in 151 | let* user = Service.User.Web.user_from_session req |> Lwt.map Option.get in 152 | let notice = Sihl.Web.Flash.find_notice req in 153 | let alert = Sihl.Web.Flash.find_alert req in 154 | let body = 155 | [%html 156 | {|
157 | Name: |} 158 | [ Html.txt ingredient.Pizza.name ] 159 | {|
160 |
Vegan: |} 161 | [ Html.txt (string_of_bool ingredient.Pizza.is_vegan) ] 162 | {|
163 |
Price: |} 164 | [ Html.txt (string_of_int ingredient.Pizza.price) ] 165 | {|
|} 166 | [ edit_link ingredient.Pizza.name ] 167 | {|
|}] 168 | in 169 | Lwt.return 170 | @@ Layout.page 171 | (Some user) 172 | [ alert_message alert; notice_message notice; body ] 173 | ;; 174 | 175 | let edit req csrf (form : Sihl.Web.Rest.form) (ingredient : Pizza.ingredient) = 176 | let open Lwt.Syntax in 177 | let* user = Service.User.Web.user_from_session req |> Lwt.map Option.get in 178 | let notice = Sihl.Web.Flash.find_notice req in 179 | let alert = Sihl.Web.Flash.find_alert req in 180 | let name, name_error = Sihl.Web.Rest.find_form "name" form in 181 | let vegan, _ = Sihl.Web.Rest.find_form "is_vegan" form in 182 | let price_value, price_error = Sihl.Web.Rest.find_form "price" form in 183 | let checkbox = 184 | if ingredient.Pizza.is_vegan 185 | || Option.equal String.equal vegan (Some "true") 186 | then 187 | [%html {||}] 188 | else [%html {||}] 189 | in 190 | let form = 191 | [%html 192 | {| 193 |
196 | 199 | 200 |
201 | Name 202 | 205 |
206 |

|} 207 | [ Html.txt (Option.value ~default:"" name_error) ] 208 | {|

209 |
210 | 211 | |} 212 | [ checkbox ] 213 | {| 214 | 215 |
216 |
217 | 218 | 223 |
224 |

|} 225 | [ Html.txt (Option.value ~default:"" price_error) ] 226 | {|

227 | 228 |
229 | |}] 230 | in 231 | Lwt.return 232 | @@ Layout.page 233 | (Some user) 234 | [ alert_message alert; notice_message notice; form ] 235 | ;; 236 | -------------------------------------------------------------------------------- /app/context/pizza/repo.ml: -------------------------------------------------------------------------------- 1 | let clean_pizzas_request = 2 | Caqti_request.exec Caqti_type.unit "TRUNCATE TABLE pizzas CASCADE;" 3 | ;; 4 | 5 | let clean_ingredients_request = 6 | Caqti_request.exec Caqti_type.unit "TRUNCATE TABLE ingredients CASCADE;" 7 | ;; 8 | 9 | let clean_pizzas_ingredients_request = 10 | Caqti_request.exec 11 | Caqti_type.unit 12 | "TRUNCATE TABLE pizzas_ingredients CASCADE;" 13 | ;; 14 | 15 | let clean () = 16 | let open Lwt_result.Syntax in 17 | Sihl.Database.query' (fun (module Connection : Caqti_lwt.CONNECTION) -> 18 | let* () = Connection.exec clean_pizzas_request () in 19 | let* () = Connection.exec clean_ingredients_request () in 20 | Connection.exec clean_pizzas_ingredients_request ()) 21 | ;; 22 | 23 | let insert_ingredient_request = 24 | Caqti_request.exec 25 | Caqti_type.(tup2 string (tup2 bool (tup2 int (tup2 ptime ptime)))) 26 | {sql| 27 | INSERT INTO ingredients ( 28 | name, 29 | is_vegan, 30 | price, 31 | created_at, 32 | updated_at 33 | ) VALUES ( 34 | $1, 35 | $2, 36 | $3, 37 | $4 AT TIME ZONE 'UTC', 38 | $5 AT TIME ZONE 'UTC' 39 | ) 40 | |sql} 41 | ;; 42 | 43 | let insert_ingredient (ingredient : Model.ingredient) = 44 | Sihl.Database.query' (fun connection -> 45 | let module Connection = (val connection : Caqti_lwt.CONNECTION) in 46 | Connection.exec 47 | insert_ingredient_request 48 | ( ingredient.Model.name 49 | , ( ingredient.Model.is_vegan 50 | , ( ingredient.Model.price 51 | , (ingredient.Model.created_at, ingredient.Model.updated_at) ) ) )) 52 | ;; 53 | 54 | let update_ingredient_request = 55 | Caqti_request.exec 56 | Caqti_type.(tup2 string (tup2 bool (tup2 int (tup2 ptime ptime)))) 57 | {sql| 58 | UPDATE ingredients SET 59 | name = $1, 60 | is_vegan = $2, 61 | price = $3, 62 | created_at = $4, 63 | updated_at = $5 64 | WHERE name = $1; 65 | |sql} 66 | ;; 67 | 68 | let update_ingredient (ingredient : Model.ingredient) = 69 | Sihl.Database.query' (fun connection -> 70 | let module Connection = (val connection : Caqti_lwt.CONNECTION) in 71 | Connection.exec 72 | update_ingredient_request 73 | ( ingredient.Model.name 74 | , ( ingredient.Model.is_vegan 75 | , ( ingredient.Model.price 76 | , (ingredient.Model.created_at, ingredient.Model.updated_at) ) ) )) 77 | ;; 78 | 79 | let find_ingredient_request = 80 | Caqti_request.find_opt 81 | Caqti_type.string 82 | Caqti_type.(tup2 string (tup2 bool (tup2 int (tup2 ptime ptime)))) 83 | {sql| 84 | SELECT 85 | name, 86 | is_vegan, 87 | price, 88 | created_at, 89 | updated_at 90 | FROM ingredients 91 | WHERE name = ? 92 | |sql} 93 | ;; 94 | 95 | let find_ingredient (name : string) : Model.ingredient option Lwt.t = 96 | let open Lwt.Syntax in 97 | let* ingredient = 98 | Sihl.Database.query' (fun connection -> 99 | let module Connection = (val connection : Caqti_lwt.CONNECTION) in 100 | Connection.find_opt find_ingredient_request name) 101 | in 102 | Lwt.return 103 | @@ Option.map 104 | (fun (name, (is_vegan, (price, (created_at, updated_at)))) -> 105 | Model.{ name; is_vegan; price; created_at; updated_at }) 106 | ingredient 107 | ;; 108 | 109 | let find_ingredients_request = 110 | Caqti_request.collect 111 | Caqti_type.unit 112 | Caqti_type.(tup2 string (tup2 bool (tup2 int (tup2 ptime ptime)))) 113 | {sql| 114 | SELECT 115 | name, 116 | is_vegan, 117 | price, 118 | created_at, 119 | updated_at 120 | FROM ingredients 121 | ORDER BY id DESC 122 | |sql} 123 | ;; 124 | 125 | let find_ingredients () : Model.ingredient list Lwt.t = 126 | let open Lwt.Syntax in 127 | let* ingredients = 128 | Sihl.Database.query' (fun connection -> 129 | let module Connection = (val connection : Caqti_lwt.CONNECTION) in 130 | Connection.collect_list find_ingredients_request ()) 131 | in 132 | Lwt.return 133 | @@ List.map 134 | ~f:(fun (name, (is_vegan, (price, (created_at, updated_at)))) -> 135 | Model.{ name; is_vegan; price; created_at; updated_at }) 136 | ingredients 137 | ;; 138 | 139 | let find_ingredients_of_pizza_request = 140 | Caqti_request.collect 141 | Caqti_type.string 142 | Caqti_type.(tup2 string (tup2 bool (tup2 int (tup2 ptime ptime)))) 143 | {sql| 144 | SELECT 145 | ingredients.name, 146 | ingredients.is_vegan, 147 | ingredients.price, 148 | ingredients.created_at, 149 | ingredients.updated_at 150 | FROM ingredients 151 | LEFT JOIN pizzas_ingredients 152 | ON ingredients.id = pizzas_ingredients.ingredient_id 153 | LEFT JOIN pizzas 154 | ON pizzas.id = pizzas_ingredients.pizza_id 155 | AND pizzas.name = ? 156 | |sql} 157 | ;; 158 | 159 | let find_ingredients_of_pizza (name : string) : Model.ingredient list Lwt.t = 160 | let open Lwt.Syntax in 161 | let* ingredients = 162 | Sihl.Database.query' (fun connection -> 163 | let module Connection = (val connection : Caqti_lwt.CONNECTION) in 164 | Connection.collect_list find_ingredients_of_pizza_request name) 165 | in 166 | Lwt.return 167 | @@ List.map 168 | ~f:(fun (name, (is_vegan, (price, (created_at, updated_at)))) -> 169 | Model.{ name; is_vegan; price; created_at; updated_at }) 170 | ingredients 171 | ;; 172 | 173 | let delete_ingredient_request = 174 | Caqti_request.exec 175 | Caqti_type.string 176 | {sql| 177 | DELETE FROM ingredients 178 | WHERE name = ? 179 | |sql} 180 | ;; 181 | 182 | let delete_ingredient (ingredient : Model.ingredient) : unit Lwt.t = 183 | Sihl.Database.query' (fun connection -> 184 | let module Connection = (val connection : Caqti_lwt.CONNECTION) in 185 | Connection.exec delete_ingredient_request ingredient.Model.name) 186 | ;; 187 | 188 | let find_pizza_request = 189 | Caqti_request.find_opt 190 | Caqti_type.string 191 | Caqti_type.(tup3 string ptime ptime) 192 | {sql| 193 | SELECT 194 | name, 195 | created_at, 196 | updated_at 197 | FROM pizzas 198 | WHERE name = ? 199 | |sql} 200 | ;; 201 | 202 | let find_pizza name = 203 | let open Lwt.Syntax in 204 | let* pizza = 205 | Sihl.Database.query' (fun connection -> 206 | let module Connection = (val connection : Caqti_lwt.CONNECTION) in 207 | Connection.find_opt find_pizza_request name) 208 | in 209 | let* ingredients = find_ingredients_of_pizza name in 210 | let ingredients = 211 | List.map 212 | ~f:(fun (ingredient : Model.ingredient) -> ingredient.Model.name) 213 | ingredients 214 | in 215 | Lwt.return 216 | @@ Option.map 217 | (fun (name, created_at, updated_at) -> 218 | Model.{ name; ingredients; created_at; updated_at }) 219 | pizza 220 | ;; 221 | 222 | let find_pizzas_request = 223 | Caqti_request.collect 224 | Caqti_type.unit 225 | Caqti_type.(tup4 string string ptime ptime) 226 | {sql| 227 | SELECT 228 | pizza_name, 229 | ingredient_name 230 | created_at, 231 | updated_at 232 | FROM pizzas 233 | LEFT JOIN pizzas_ingredients 234 | ON pizzas_ingredients.pizza_id = pizzas.id 235 | LEFT JOIN ingredients 236 | ON ingredients.id = pizzas_ingredients.ingredient_id 237 | |sql} 238 | ;; 239 | 240 | let find_pizzas () = failwith "todo find_pizzas" 241 | 242 | (* let open Lwt.Syntax in 243 | * let* pizzas = 244 | * Sihl.Database.query' (fun connection -> 245 | * let module Connection = (val connection : Caqti_lwt.CONNECTION) in 246 | * Connection.collect_list find_pizzas_request ()) 247 | * in 248 | * Lwt.return 249 | * @@ List.map 250 | * ~f:(fun (name, created_at, updated_at) -> 251 | * Model.{ name; ingredients; created_at; updated_at }) 252 | * pizzas 253 | * ;; *) 254 | 255 | let insert_pizza_request = 256 | Caqti_request.exec 257 | Caqti_type.(tup3 string ptime ptime) 258 | {sql| 259 | INSERT INTO pizzas ( 260 | name, 261 | created_at, 262 | updated_at 263 | ) VALUES ( 264 | $1, 265 | $2 AT TIME ZONE 'UTC', 266 | $3 AT TIME ZONE 'UTC' 267 | ) 268 | |sql} 269 | ;; 270 | 271 | let insert_pizza_ingredient_request = 272 | Caqti_request.exec 273 | Caqti_type.(tup2 string string) 274 | {sql| 275 | INSERT INTO pizzas_ingredients ( 276 | pizza_id, 277 | ingredient_id 278 | ) VALUES ( 279 | (SELECT id FROM pizzas WHERE pizzas.name = $1), 280 | (SELECT id FROM ingredients WHERE ingredients.name = $2) 281 | ) 282 | |sql} 283 | ;; 284 | 285 | let insert_pizza (pizza : Model.t) (ingredients : string list) = 286 | let open Lwt_result.Syntax in 287 | Sihl.Database.transaction' (fun connection -> 288 | let module Connection = (val connection : Caqti_lwt.CONNECTION) in 289 | let* () = 290 | Connection.exec 291 | insert_pizza_request 292 | (pizza.Model.name, pizza.Model.created_at, pizza.Model.updated_at) 293 | in 294 | let* () = 295 | Connection.populate 296 | ~table:"ingredients" 297 | ~columns:[ "name" ] 298 | Caqti_type.string 299 | (Caqti_lwt.Stream.of_list ingredients) 300 | |> Lwt.map Caqti_error.uncongested 301 | in 302 | List.fold_left 303 | ~f:(fun result ingredient -> 304 | let* () = result in 305 | Connection.exec 306 | insert_pizza_ingredient_request 307 | (pizza.Model.name, ingredient)) 308 | ~init:(Lwt_result.return ()) 309 | ingredients) 310 | ;; 311 | 312 | let add_ingredient_to_pizza pizza ingredient = 313 | Sihl.Database.query' (fun connection -> 314 | let module Connection = (val connection : Caqti_lwt.CONNECTION) in 315 | Connection.exec insert_pizza_ingredient_request (pizza, ingredient)) 316 | ;; 317 | 318 | let delete_pizza_request = 319 | Caqti_request.exec 320 | Caqti_type.string 321 | {sql| 322 | DELETE FROM pizzas 323 | WHERE name = ? 324 | |sql} 325 | ;; 326 | 327 | let delete_pizza (pizza : Model.t) : unit Lwt.t = 328 | (* We don't need to remove the pizzas_ingredients entry because of 329 | CASCADING *) 330 | Sihl.Database.query' (fun connection -> 331 | let module Connection = (val connection : Caqti_lwt.CONNECTION) in 332 | Connection.exec delete_pizza_request pizza.Model.name) 333 | ;; 334 | --------------------------------------------------------------------------------