├── .envrc ├── .github └── workflows │ └── ci.yaml ├── .gitignore ├── ARCHITECTURE.md ├── LICENSE ├── README.md ├── Taskfile.yml ├── app └── Main.hs ├── config.toml ├── docker-compose.yml ├── elm ├── .gitignore ├── README.md ├── elm.json ├── index.js └── src │ ├── Anonymous.elm │ ├── Component.elm │ ├── Credentials.elm │ ├── Logged.elm │ ├── LoggedModel.elm │ ├── Main.elm │ ├── Style.elm │ └── Tags.elm ├── flake.lock ├── flake.nix ├── hie.yaml ├── package.yaml ├── schema.sql ├── scripts └── db │ ├── destroy │ └── setup ├── servant-template.cabal ├── spec ├── Spec.hs ├── TaggerSpec.hs └── TestServices.hs └── src ├── API ├── AppServices.hs ├── Application.hs ├── Authentication.hs ├── Config.hs ├── Docs.hs ├── Healthcheck.hs └── Tagger.hs ├── App.hs ├── CLIOptions.hs ├── Dependencies.hs ├── Impl ├── Authentication │ └── Authenticator.hs └── Repository │ ├── Content.hs │ ├── Content │ ├── InMemory.hs │ └── Postgres.hs │ ├── User.hs │ └── User │ ├── Error.hs │ ├── InMemory.hs │ └── Postgres.hs ├── Infrastructure ├── Authentication │ ├── PasswordManager.hs │ └── Token.hs ├── Database.hs ├── Logging │ └── Logger.hs ├── Persistence │ ├── Queries.hs │ ├── Schema.hs │ └── Serializer.hs └── SystemTime.hs ├── Middleware.hs └── Tagger ├── Authentication ├── Authenticator.hs └── Credentials.hs ├── Content.hs ├── EncryptedPassword.hs ├── Id.hs ├── JSONWebKey.hs ├── Owned.hs ├── Repository ├── Content.hs └── User.hs ├── Tag.hs └── User.hs /.envrc: -------------------------------------------------------------------------------- 1 | use flake -------------------------------------------------------------------------------- /.github/workflows/ci.yaml: -------------------------------------------------------------------------------- 1 | name: "Test" 2 | on: 3 | pull_request: 4 | push: 5 | jobs: 6 | CI: 7 | runs-on: ubuntu-latest 8 | steps: 9 | - uses: actions/checkout@v3 10 | - uses: cachix/install-nix-action@v22 11 | with: 12 | nix_path: nixpkgs=channel:nixos-unstable 13 | - uses: actions/cache@v3 14 | with: 15 | path: | 16 | ~/.cabal/store 17 | dist-newstyle 18 | key: ${{ runner.os }}-${{ matrix.ghc }} 19 | - run: nix develop -c task api:test 20 | - run: nix flake check 21 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .direnv 2 | .hie 3 | .jwk 4 | .postgres 5 | .pre-commit-config.yaml 6 | .task 7 | result 8 | dist-newstyle -------------------------------------------------------------------------------- /ARCHITECTURE.md: -------------------------------------------------------------------------------- 1 | # Architectural documentation 2 | 3 | `Tagger` is a simple application created to showcase `Servant` and how to integrate it into a working application. 4 | 5 | The project is structured in three layers: 6 | - the `Tagger` folder contains the business domain of the application; 7 | - the `Infrastructure` folder contains the implementation of the services needed by the application; 8 | - the `API` folder contains the application layer which connects the external world and the previous two layers. 9 | 10 | There is a dependency between the layers which works as follows 11 | 12 | ```mermaid 13 | graph TD; 14 | Infrastructure --> Domain; 15 | Application --> Infrastructure; 16 | Application --> Domain; 17 | ``` 18 | 19 | where each arrow denotes an allowed dependency. 20 | 21 | In other words, the `Domain` of the application can never access either the `Infrastructure` or the `Application` layer. The `Infrastructure` layer can only access the `Domain` layer and the `Application` layer has actually access to everything. 22 | 23 | ## Domain 24 | 25 | The domain of the application contains the relevant domain entities, as `Content`, `Tag` and `User`. 26 | 27 | Identifiers of domain entities are not included in the entities themselves and are instead managed using an `Id` data type, which has a phantom type used to specify which entity it is actually identifying. 28 | 29 | The domain layer contains also the [repositories](https://www.martinfowler.com/eaaCatalog/repository.html), defined as records of functions, to interact with collections of domain objects. Those records are parameterized by a monadic context `m` in order to define the interface of repositories without committing to a particular implementation. 30 | 31 | ### A concrete example 32 | 33 | For example, to interact with `User`s, we have a `UserRepository` which abstracts the operations concerning users 34 | 35 | ```haskell 36 | data UserRepository m = UserRepository 37 | { getUserByName :: Text -> m (Id User, User) 38 | , addUser :: User -> m (Id User) 39 | } 40 | ``` 41 | 42 | These operations define an interface which allows us to interact with an abstract model of a collection of `User`s. 43 | In practice, if we wanted to combine these operation, we would need to impose restrictions on the context `m` in exchange for a more powerful api. For example, to allow sequential composition of such operations, we would need to restrict `m` to be a `Monad`. Similarly, if we wanted to grant to these operations the possiblity of failure, we could add a `MonadError` contraint. Broadly speaking, we could use `mtl`-style typeclasses to restrict the allowed contexts in exchange for more computational expressivity. 44 | 45 | ## Infrastructure 46 | 47 | The infrastructure layer provides the implementations needed by the application. Specifically it provides access to the database, to error logging and user authentication. 48 | 49 | ### Persistence 50 | 51 | Contains the implementation, based on `PostgreSQL`, of the repositories defined in the domain layer. 52 | 53 | In the concrete implementations we specialize the context `m` of the repositories to `ExceptT e IO` so that we can work in a concrete monad. 54 | 55 | The repositories are combining the queries defined at the database level and are using the serialization/unserialization mechanism to convert between the domain entities and their representation at the database level. 56 | 57 | #### A concrete example 58 | 59 | Continuing the example introducted above, in the infrastructure layer we choose a concrete monad stack where we want to work. Specifically, for our repositories, we need to perform `IO` to interact with the database and we need to allow the possibility of failures, since we might not find the records we are looking for in the database. Therefore we specialize our generic context `m` to `ExceptT e IO`, where the `e` error type depends on the repository itself. 60 | 61 | This leads us to define our `postgresUserRepository` as 62 | 63 | ```haskell 64 | postgresUserRepository :: Connection -> UserRepository (ExceptT UserRepositoryError IO) 65 | postgresUserRepository connection = UserRepository 66 | { getUserByName = postgresGetUserByName connection 67 | , addUser = postgresAddUser connection 68 | } 69 | ``` 70 | 71 | where `postgresGetUserByName` and `postgresAddUser` contain the actual logic to run the correct queries in [PostgreSQL](https://www.postgresql.org). 72 | 73 | ### Logging 74 | 75 | Provides to the application the ability of logging error messages. 76 | 77 | ### Authentication 78 | 79 | It contains two services, `PasswordManager` and `AuthenticateUser`, where the latter is using the former. 80 | 81 | Being infrastructural services their interface and implementation are defined together in the same module. 82 | 83 | ## Application 84 | 85 | The application layer deals mainly with two issues: 86 | - setting up all the services required by the application 87 | - describing and implementing the API of the application 88 | 89 | ### Services 90 | 91 | The `AppServices` modules deals with building all the required services and packing them all together. 92 | 93 | To achieve this we first need to choose an explicit implementation for each service. 94 | 95 | At this level we want all the services to work directly in the `Handler` monad. This requires us to hoist the services from the concrete context where they are initially defined to `Handler`. 96 | 97 | Doing so implies that we also need to handle the errors generated by the services. Hence at this point we decide how to log the error messages and which status code is appropriate for every specific error. 98 | 99 | #### A concrete example 100 | 101 | Considering our recurring example with `UserRepository`, at the domain level we're using a generic monadic context `m`, while at the infrastructure level we specialized it to `ExceptT UserRepositoryError IO`. 102 | 103 | Now, at the application level, we're working in the `Handler` context, because that is where `Servant` handlers operate. To fill the gap and connect all the pieces, we hoist the `ExceptT UserRepositoryError IO` context into the `Handler` one, using a natural transformation `forall a. ExceptT UserRepositoryError IO a -> Handler a`. 104 | 105 | ```haskell 106 | postgresUserRepository :: UserRepository (ExceptT UserRepositoryError IO) 107 | 108 | hoistUserRepository :: (forall a. m a -> n a) -> UserRepository m -> UserRepository n 109 | 110 | eitherTToHandler :: forall a. ExceptT UserRepositoryError IO a -> Handler a 111 | 112 | handlerUserRepository :: UserRepository Handler 113 | handlerUserRepository = hoistUserRepository eitherTToHandler postgresUserRepository 114 | ``` 115 | 116 | ### API endpoints 117 | 118 | Once we setup all the required services, we can pass them to the API endpoints which are defined in the `Application` module. 119 | 120 | We make use of Servant `NamedRoutes` to define our API is a clear and composable way, splitting their respective handlers in several modules. 121 | 122 | ### Configuration 123 | 124 | Another issue which is dealt with at the application level is configuration. 125 | 126 | We define the schema of the required configuration and a bidirectional codec. 127 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) Tweag I/O Limited. 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ![CI](https://github.com/tweag/servant-template/actions/workflows/ci.yaml/badge.svg) 2 | 3 | # servant-template 4 | 5 | A modern template for a [Servant](https://haskell-servant.github.io/) application. 6 | 7 | ## Scope 8 | 9 | The project aims to provide a template for a Servant project featuring: 10 | 11 | - `nix` support via flakes. 12 | - database interaction with [rel8](https://hackage.haskell.org/package/rel8); 13 | - JWT authentication with [servant-auth](https://hackage.haskell.org/package/servant-auth); 14 | - logging with [co-log-core](https://hackage.haskell.org/package/co-log-core); 15 | - TOML configuration using [tomland](https://hackage.haskell.org/package/tomland); 16 | - first class records in Servant API using [NamedRecords](https://hackage.haskell.org/package/servant-0.19/changelog). 17 | 18 | ## The application 19 | 20 | The application allows users to categorify contents by tags. Any content can have many tags and any tag could be used for several contents. 21 | 22 | It allows also to retrieve contents by a set of tags. 23 | 24 | ### Architecture 25 | 26 | A more in depth description of the architecture of the application can be found in [ARCHITECTURE.md](./ARCHITECTURE.md). 27 | 28 | ### Configuration 29 | 30 | Configuration of the application is managed using [TOML](https://toml.io). The application requires a configuration file with the following format: 31 | 32 | ```toml 33 | [database] 34 | host = "localhost" 35 | port = 5432 36 | dbname = "tagger-db" 37 | user = "tagger-user" 38 | password = "tagger-pwd" 39 | 40 | [api] 41 | port = 8080 42 | ``` 43 | 44 | By default, the file is located in `config.toml`, but the path is actually configurable with the `config` option. 45 | 46 | ### Authentication 47 | 48 | The main endpoints of the application are protected by JWT authentication. To access them you first need to get an authorization token for a user. 49 | 50 | To get it you first need to register a user by calling the `register` endpoint. 51 | 52 | Next, you can obtain a token by calling the `login` endpoint with the same data provided to the register endpoint. 53 | 54 | Eventually, you should pass your token in the `Authorization` header for the relevant endpoints to access them. 55 | 56 | ## Development 57 | 58 | The project is setup to be built with [Cabal](https://cabal.readthedocs.io/en/latest/cabal-commands.html), though with dependencies provided via [Nix](https://nixos.org/). 59 | Tasks are provided using a GNU Make-like tool called [Task](https://taskfile.dev/) and are supposed to be run inside a Nix shell. 60 | 61 | Available tasks can be seen with `task --list`: 62 | 63 | ```sh 64 | ❯ task --list 65 | task: Available tasks for this project: 66 | * api:build: Build the API 67 | * api:dev: Typecheck the API in a loop 68 | * api:docs: Build Haddock docs 69 | * api:repl: Start a cabal REPL 70 | * api:serve: Serve the API 71 | * api:test: Run API tests 72 | * db:destroy: Destroy the database 73 | * db:setup: Setup a postgres database using the config file 74 | * fe:build: Build the frontend app 75 | * fe:serve: Serve the frontend app 76 | ``` 77 | 78 | The usage of tasks is completely optional, and direct invocations of `cabal` (e.g. `cabal build`, `cabal test`, etc.) and `elm` commands are also valid. 79 | 80 | > :information_source: If `direnv` is installed, it is also possible to use it with `nix`. The provided `.envrc` file is already configured to use `nix` and only needs to be enabled by issuing `direnv allow` in the project root once. 81 | 82 | ### Setup 83 | 84 | Setting up the runtime dependencies for development, such as the database, is taken care of by `task setup`. This calls individual components' setup scripts such as `task db:setup` under the hood, if you prefer to call it directly. 85 | 86 | This task (and others in general) assumes the existence of a few packages (`toml2json`, `jq`, `postgres`, etc.) provided by the nix shell. 87 | 88 | #### Alternative: docker 89 | 90 | In the root of the project you can find a `docker-compose.yml` file which provides a Postgresql database and a web interface to it, exposed on port `8081`. 91 | You can initialise the schema of the database by running the `schema.sql` which is also provided. 92 | 93 | ### Building the API 94 | 95 | To build the API, run 96 | 97 | ```sh 98 | # With task 99 | task api:build 100 | 101 | # With cabal 102 | cabal build 103 | ``` 104 | 105 | > :warning: Note for non-nix users: the build requires the presence of the `pg_config` executable which is made available by installing Postgresql. Nix takes care of this automatically. 106 | 107 | ### Serving the API for development 108 | 109 | You can launch the web server using 110 | 111 | ```sh 112 | # With task 113 | task api:serve 114 | 115 | ### Running the API tests 116 | 117 | To run the tests, run 118 | 119 | ```sh 120 | # With task 121 | task api:test 122 | 123 | # With Cabal 124 | cabal test 125 | ``` 126 | 127 | which will expose the service on port defined in configuration. 128 | 129 | > :warning: Note for non-nix users: serving the API with hot-reloading requires the presence of the `watchexec` utility which is made available by the nix shell. Install it manually if you wish to use this script. 130 | 131 | The executable accepts two options: 132 | 133 | - `--config`, which allows to customize the path of the configuration file 134 | - `--jwk`, which allows to customize the path of the file where the JWK is stored 135 | 136 | ### Formatting 137 | The Haskell files are formatted using `ormolu`. The Elm source code is formatted using `elm-format`. The executables are provided in the nix shell. 138 | 139 | ### Pre-commit hooks 140 | Git commit hooks are installed by the nix shell and run checks before a commit. These include linting, formatting, etc. 141 | 142 | These checks can also be run manually with `pre-commit run`. 143 | 144 | ## Documentation 145 | 146 | You can generate the documentation of the project using 147 | 148 | ```sh 149 | # With task 150 | task api:docs 151 | 152 | # With Cabal 153 | cabal haddock 154 | ``` 155 | 156 | ### OpenApi documentation 157 | 158 | You can access the OpenAPI documentation just by visiting the `docs` endpoint (by default http://localhost:8080/docs) 159 | 160 | ## Frontend 161 | 162 | This repository contains also a client [Elm](https://elm-lang.org/) application to interact in a human-friendly way with the Tagger api. 163 | 164 | You can find more details in [elm/README.md](elm/README.md), but there are convenience commands: 165 | 166 | ### Building the project 167 | ```sh 168 | # With task 169 | task fe:build 170 | 171 | # With nix 172 | nix-shell --run 'cd elm; elm make src/Main.elm' 173 | 174 | # With npm 175 | cd elm; npx elm make src/Main.elm 176 | ``` 177 | 178 | ### Serve project for development 179 | ```sh 180 | # With task 181 | task fe:serve 182 | 183 | # With nix 184 | nix-shell --run 'cd elm; elm-live src/Main.elm' 185 | 186 | # With npm 187 | cd elm; npx elm-live src/Main.elm 188 | ``` 189 | -------------------------------------------------------------------------------- /Taskfile.yml: -------------------------------------------------------------------------------- 1 | version: '3' 2 | 3 | env: 4 | API_EXECUTABLE: servant-template-exe 5 | 6 | tasks: 7 | setup: 8 | desc: Setup the necessary services for the application 9 | deps: [db:setup] 10 | 11 | api:build: 12 | desc: Build the API 13 | sources: 14 | - 'app/**/*.hs' 15 | - 'src/**/*.hs' 16 | - 'spec/**/*.hs' 17 | - '**/*.nix' 18 | - 'package.yaml' 19 | - 'Taskfile.yml' 20 | - 'config.toml' 21 | cmds: 22 | - cabal build {{.CLI_ARGS}} 23 | 24 | api:serve: 25 | desc: Serve the API 26 | deps: [db:setup, api:build] 27 | interval: '500ms' 28 | cmds: 29 | - cmd: pkill -f $API_EXECUTABLE || true 30 | silent: true 31 | - cmd: cabal run $API_EXECUTABLE {{.CLI_ARGS}} 32 | ignore_error: true 33 | 34 | api:dev: 35 | desc: Typecheck the API in a loop 36 | cmds: 37 | - ghcid --command "cabal repl" 38 | 39 | api:repl: 40 | desc: Start a cabal REPL 41 | cmds: 42 | - cabal repl 43 | 44 | api:test: 45 | desc: Run API tests 46 | deps: [api:build] 47 | cmds: 48 | - cabal test 49 | 50 | api:docs: 51 | desc: Build Haddock docs 52 | cmds: 53 | - cabal haddock 54 | 55 | db:setup: 56 | desc: Setup a postgres database using the config file 57 | cmds: 58 | - ./scripts/db/setup 59 | 60 | db:destroy: 61 | desc: Destroy the database 62 | cmds: 63 | - ./scripts/db/destroy 64 | 65 | fe:build: 66 | desc: Build the frontend app 67 | dir: elm 68 | cmds: 69 | - elm make src/Main.elm {{.CLI_ARGS}} 70 | 71 | fe:serve: 72 | desc: Serve the frontend app 73 | dir: elm 74 | cmds: 75 | - elm-live src/Main.elm {{.CLI_ARGS}} 76 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import App 4 | 5 | main :: IO () 6 | main = run 7 | -------------------------------------------------------------------------------- /config.toml: -------------------------------------------------------------------------------- 1 | [database] 2 | host = "localhost" 3 | port = 5432 4 | dbname = "tagger-db" 5 | user = "tagger-user" 6 | password = "tagger-pwd" 7 | 8 | [api] 9 | port = 8080 10 | -------------------------------------------------------------------------------- /docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: '3' 2 | 3 | services: 4 | postgres: 5 | image: postgres:14-alpine 6 | container_name: postgres 7 | environment: 8 | - POSTGRES_USER=tagger-user 9 | - POSTGRES_PASSWORD=tagger-pwd 10 | - POSTGRES_DB=tagger-db 11 | volumes: 12 | - ./data:/var/lib/postgresql/data 13 | ports: 14 | - 5432:5432 15 | networks: 16 | - default 17 | 18 | pgadmin: 19 | image: dpage/pgadmin4:6.13 20 | container_name: pgadmin 21 | environment: 22 | - PGADMIN_DEFAULT_EMAIL=user@domain.com 23 | - PGADMIN_DEFAULT_PASSWORD=password 24 | links: 25 | - postgres:postgres 26 | depends_on: 27 | - postgres 28 | volumes: 29 | - ./dump:/dump 30 | ports: 31 | - 8081:80 32 | networks: 33 | - default 34 | 35 | networks: 36 | default: 37 | driver: bridge 38 | -------------------------------------------------------------------------------- /elm/.gitignore: -------------------------------------------------------------------------------- 1 | node_modules/ 2 | dist/ 3 | elm-stuff 4 | index.html 5 | -------------------------------------------------------------------------------- /elm/README.md: -------------------------------------------------------------------------------- 1 | # Tagger Elm client 2 | 3 | This folder contains a client application built with [Elm](https://elm-lang.org/), which allows interacting in a human-friendly way with the Tagger API. 4 | 5 | ## Building 6 | 7 | You can build the client application using 8 | 9 | ```sh 10 | # From the project root with convenience script 11 | bin/frontend/build 12 | 13 | # From the project root with nix 14 | nix-shell --run 'cd elm; elm make src/Main.elm' 15 | 16 | # With npm 17 | elm make src/Main.elm 18 | ``` 19 | 20 | ## Serving for development 21 | 22 | You can start the application with live reload using: 23 | 24 | ```sh 25 | # From the project root with convenience script 26 | bin/frontend/serve 27 | 28 | # From the project root with nix 29 | nix-shell --run 'cd elm; elm-live src/Main.elm' 30 | 31 | # With npm 32 | cd elm; elm-live src/Main.elm' 33 | ``` 34 | 35 | It will open a new tab in your browser with the time-traveler available. 36 | 37 | ## Workflow 38 | 39 | The application requires you to first register a new user. Once this is done, you can log in with the same credentials and access the private area. 40 | 41 | In the private area, you'll see the contents for the logged-in user, and you can also: 42 | 43 | - add new contents with their tags; 44 | - filter the shown contents by tag. 45 | -------------------------------------------------------------------------------- /elm/elm.json: -------------------------------------------------------------------------------- 1 | { 2 | "type": "application", 3 | "source-directories": [ 4 | "src" 5 | ], 6 | "elm-version": "0.19.1", 7 | "dependencies": { 8 | "direct": { 9 | "elm/browser": "1.0.2", 10 | "elm/core": "1.0.5", 11 | "elm/html": "1.0.0", 12 | "elm/http": "2.0.0", 13 | "elm/json": "1.1.3", 14 | "elm/url": "1.0.0", 15 | "mdgriffith/elm-ui": "1.1.8" 16 | }, 17 | "indirect": { 18 | "elm/bytes": "1.0.8", 19 | "elm/file": "1.0.5", 20 | "elm/time": "1.0.0", 21 | "elm/virtual-dom": "1.0.2" 22 | } 23 | }, 24 | "test-dependencies": { 25 | "direct": {}, 26 | "indirect": {} 27 | } 28 | } 29 | -------------------------------------------------------------------------------- /elm/index.js: -------------------------------------------------------------------------------- 1 | import { Elm } from "./src/Main.elm"; 2 | 3 | Elm.Main.init({ node: document.getElementById("root") }); 4 | -------------------------------------------------------------------------------- /elm/src/Anonymous.elm: -------------------------------------------------------------------------------- 1 | module Anonymous exposing (..) 2 | 3 | import Component exposing (..) 4 | import Credentials exposing (..) 5 | import Element exposing (..) 6 | import Json.Decode exposing (..) 7 | 8 | 9 | 10 | -- MODEL 11 | 12 | 13 | type alias UserId = 14 | String 15 | 16 | 17 | type alias Token = 18 | String 19 | 20 | 21 | type alias Model = 22 | { register : Credentials.Model 23 | , login : Credentials.Model 24 | , registerSubmit : Submit UserId 25 | , loginSubmit : Submit Token 26 | } 27 | 28 | 29 | init : () -> ( Model, Cmd Msg ) 30 | init _ = 31 | ( { register = emptyCredentials 32 | , login = emptyCredentials 33 | , registerSubmit = NotYetSubmitted 34 | , loginSubmit = NotYetSubmitted 35 | } 36 | , Cmd.none 37 | ) 38 | 39 | 40 | 41 | -- UPDATE 42 | 43 | 44 | type Msg 45 | = RegisterData CredentialsMessage 46 | | LoginData CredentialsMessage 47 | | Register (SubmitMessage UserId) 48 | | Login (SubmitMessage Token) 49 | 50 | 51 | updateModelWithRegisterSubmit : Model -> Submit UserId -> Model 52 | updateModelWithRegisterSubmit model registerSubmit = 53 | { model | registerSubmit = registerSubmit } 54 | 55 | 56 | updateModelWithLoginSubmit : Model -> Submit Token -> Model 57 | updateModelWithLoginSubmit model loginSubmit = 58 | { model | loginSubmit = loginSubmit } 59 | 60 | 61 | update : Msg -> Model -> ( Model, Cmd Msg ) 62 | update msg model = 63 | case msg of 64 | RegisterData credentialsMessage -> 65 | ( { model | register = updateCredentials credentialsMessage model.register }, Cmd.none ) 66 | 67 | LoginData credentialsMessage -> 68 | ( { model | login = updateCredentials credentialsMessage model.login }, Cmd.none ) 69 | 70 | Register registerMessage -> 71 | Tuple.mapBoth 72 | (updateModelWithRegisterSubmit model) 73 | (Cmd.map Register) 74 | (updateSubmit userIdDecoder "http://localhost:8080/register" model.register registerMessage model.registerSubmit) 75 | 76 | Login loginMessage -> 77 | Tuple.mapBoth 78 | (updateModelWithLoginSubmit model) 79 | (Cmd.map Login) 80 | (updateSubmit tokenDecoder "http://localhost:8080/login" model.login loginMessage model.loginSubmit) 81 | 82 | 83 | 84 | -- VIEW 85 | 86 | 87 | view : Model -> Element Msg 88 | view model = 89 | Component.mainRow 90 | [ Credentials.view "Register User" RegisterData Register model.register 91 | , Credentials.view "Login" LoginData Login model.login 92 | ] 93 | 94 | 95 | 96 | -- HTTP 97 | 98 | 99 | userIdDecoder : Decoder UserId 100 | userIdDecoder = 101 | Json.Decode.string 102 | 103 | 104 | tokenDecoder : Decoder Token 105 | tokenDecoder = 106 | Json.Decode.string 107 | -------------------------------------------------------------------------------- /elm/src/Component.elm: -------------------------------------------------------------------------------- 1 | module Component exposing (..) 2 | 3 | import Element exposing (..) 4 | import Element.Background exposing (..) 5 | import Element.Border exposing (..) 6 | import Element.Font 7 | import Element.Input exposing (..) 8 | import Style exposing (..) 9 | 10 | 11 | mainRow : List (Element msg) -> Element msg 12 | mainRow elements = 13 | row [ Element.width fill ] elements 14 | 15 | 16 | mainColumn : List (Element msg) -> Element msg 17 | mainColumn elements = 18 | column 19 | [ normalPadding 20 | , bigSpacing 21 | , Element.width fill 22 | , alignTop 23 | ] 24 | elements 25 | 26 | 27 | columnTitle : String -> Element msg 28 | columnTitle title = 29 | el [ Element.centerX ] (Element.text title) 30 | 31 | 32 | button : msg -> String -> Element msg 33 | button message label = 34 | Element.Input.button 35 | ([ Element.padding 5 36 | , Element.focused [ Element.Background.color purple ] 37 | ] 38 | ++ buttonStyle 39 | ) 40 | { onPress = Just message 41 | , label = Element.text label 42 | } 43 | 44 | 45 | tableHeader : String -> Element msg 46 | tableHeader header = 47 | Element.el 48 | [ headerFont 49 | , Element.Font.center 50 | ] 51 | (Element.text header) 52 | -------------------------------------------------------------------------------- /elm/src/Credentials.elm: -------------------------------------------------------------------------------- 1 | module Credentials exposing (..) 2 | 3 | import Component exposing (..) 4 | import Element exposing (..) 5 | import Element.Background exposing (..) 6 | import Element.Border exposing (..) 7 | import Element.Input exposing (..) 8 | import Http exposing (..) 9 | import Json.Decode exposing (..) 10 | import Json.Encode exposing (..) 11 | import Style exposing (..) 12 | 13 | 14 | 15 | -- MODEL 16 | 17 | 18 | type alias Model = 19 | { username : String 20 | , password : String 21 | } 22 | 23 | 24 | emptyCredentials : Model 25 | emptyCredentials = 26 | { username = "" 27 | , password = "" 28 | } 29 | 30 | 31 | type Submit a 32 | = NotYetSubmitted 33 | | Successful a 34 | | Failure Http.Error 35 | 36 | 37 | 38 | -- UPDATE 39 | 40 | 41 | type CredentialsMessage 42 | = Username String 43 | | Password String 44 | 45 | 46 | updateCredentials : CredentialsMessage -> Model -> Model 47 | updateCredentials credentialsMessage credentials = 48 | case credentialsMessage of 49 | Username name -> 50 | { credentials | username = name } 51 | 52 | Password password -> 53 | { credentials | password = password } 54 | 55 | 56 | type SubmitMessage a 57 | = Submit 58 | | Failed Http.Error 59 | | Succeeded a 60 | 61 | 62 | updateSubmit : Decoder a -> String -> Model -> SubmitMessage a -> Submit a -> ( Submit a, Cmd (SubmitMessage a) ) 63 | updateSubmit decoder url credentials submitMessage model = 64 | case submitMessage of 65 | Submit -> 66 | ( model, submit decoder url credentials ) 67 | 68 | Failed error -> 69 | ( Failure error, Cmd.none ) 70 | 71 | Succeeded value -> 72 | ( Successful value, Cmd.none ) 73 | 74 | 75 | 76 | -- VIEW 77 | 78 | 79 | view : String -> (CredentialsMessage -> msg) -> (SubmitMessage a -> msg) -> Model -> Element msg 80 | view title liftModel liftMessage credentials = 81 | Component.mainColumn 82 | [ Component.columnTitle title 83 | , column 84 | [ normalSpacing 85 | , Element.centerX 86 | ] 87 | [ Element.map liftModel 88 | (column 89 | [ normalSpacing 90 | ] 91 | [ Element.Input.username [] 92 | { onChange = Username 93 | , text = credentials.username 94 | , placeholder = Just (Element.Input.placeholder [] (Element.text "Username")) 95 | , label = labelAbove [] (Element.text "Username") 96 | } 97 | , Element.Input.newPassword [] 98 | { onChange = Password 99 | , text = credentials.password 100 | , placeholder = Just (Element.Input.placeholder [] (Element.text "Password")) 101 | , label = labelAbove [] (Element.text "Password") 102 | , show = False 103 | } 104 | ] 105 | ) 106 | , Element.map liftMessage (Component.button Submit "Submit") 107 | ] 108 | ] 109 | 110 | 111 | 112 | -- HTTP 113 | 114 | 115 | submit : Decoder a -> String -> Model -> Cmd (SubmitMessage a) 116 | submit decoder url register = 117 | Http.post 118 | { url = url 119 | , body = 120 | jsonBody 121 | (Json.Encode.object 122 | [ ( "username", Json.Encode.string register.username ) 123 | , ( "password", Json.Encode.string register.password ) 124 | ] 125 | ) 126 | , expect = expectJson handleSubmitResponse decoder 127 | } 128 | 129 | 130 | handleSubmitResponse : Result Http.Error a -> SubmitMessage a 131 | handleSubmitResponse result = 132 | case result of 133 | Ok value -> 134 | Succeeded value 135 | 136 | Err error -> 137 | Failed error 138 | -------------------------------------------------------------------------------- /elm/src/Logged.elm: -------------------------------------------------------------------------------- 1 | module Logged exposing (..) 2 | 3 | import Anonymous exposing (..) 4 | import Component exposing (..) 5 | import Element exposing (..) 6 | import Element.Border exposing (..) 7 | import Element.Input exposing (..) 8 | import Http exposing (..) 9 | import Json.Decode exposing (..) 10 | import Json.Encode exposing (..) 11 | import LoggedModel exposing (..) 12 | import Set exposing (..) 13 | import Style exposing (..) 14 | import Tags exposing (..) 15 | import Url exposing (..) 16 | import Url.Builder exposing (..) 17 | 18 | 19 | 20 | -- MODEL 21 | 22 | 23 | type alias Model = 24 | { token : Token 25 | , contents : List Content 26 | , filters : Tags.Model 27 | , newContent : String 28 | , newTags : Tags.Model 29 | } 30 | 31 | 32 | init : Token -> Model 33 | init token = 34 | Model token [] Tags.init "" Tags.init 35 | 36 | 37 | 38 | -- UPDATE 39 | 40 | 41 | type Msg 42 | = FetchSuccessful (List Content) 43 | | FetchFailed Http.Error 44 | | NewContent String 45 | | NewFilter Tags.Msg 46 | | NewTag Tags.Msg 47 | | SubmitContent 48 | | SubmitSuccessful Content 49 | | SubmitFailed 50 | 51 | 52 | update : Msg -> Model -> ( Model, Cmd Msg ) 53 | update msg model = 54 | case msg of 55 | FetchSuccessful contents -> 56 | ( { model | contents = contents }, Cmd.none ) 57 | 58 | FetchFailed _ -> 59 | ( model, Cmd.none ) 60 | 61 | NewContent newContent -> 62 | ( { model | newContent = newContent }, Cmd.none ) 63 | 64 | NewFilter filterMsg -> 65 | Tuple.mapFirst (\filters -> { model | filters = filters }) (Tags.update (retrieveContents model.token) filterMsg model.filters) 66 | 67 | NewTag tagMsg -> 68 | Tuple.mapFirst (\newTags -> { model | newTags = newTags }) (Tags.update (always Cmd.none) tagMsg model.newTags) 69 | 70 | SubmitContent -> 71 | ( model, addContent model.token (Content model.newContent model.newTags.tags) ) 72 | 73 | SubmitSuccessful content -> 74 | ( { model | contents = content :: model.contents }, Cmd.none ) 75 | 76 | SubmitFailed -> 77 | ( model, Cmd.none ) 78 | 79 | 80 | 81 | -- VIEW 82 | 83 | 84 | viewTag : Tag -> Element msg 85 | viewTag tag = 86 | Element.el 87 | [ normalPadding 88 | , normalSpacing 89 | ] 90 | (Element.text tag) 91 | 92 | 93 | view : Model -> Element Msg 94 | view model = 95 | Component.mainRow 96 | [ Component.mainColumn 97 | [ Component.columnTitle "Contents" 98 | , Element.map NewFilter (Tags.view viewTag "Filter by tag" "Add filter" model.filters) 99 | , Element.table 100 | [ normalPadding 101 | ] 102 | { data = model.contents 103 | , columns = 104 | [ { header = tableHeader "Content" 105 | , width = fill 106 | , view = 107 | \content -> 108 | Element.el 109 | (normalPadding :: tableRowStyle) 110 | (Element.text content.message) 111 | } 112 | , { header = tableHeader "Tags" 113 | , width = fill 114 | , view = 115 | \content -> 116 | Element.el 117 | tableRowStyle 118 | (row [] (List.map viewTag (toList content.tags))) 119 | } 120 | ] 121 | } 122 | ] 123 | , Component.mainColumn 124 | [ Component.columnTitle "Add content" 125 | , Element.Input.text [] 126 | { onChange = NewContent 127 | , text = model.newContent 128 | , placeholder = Just (Element.Input.placeholder [] (Element.text "New content")) 129 | , label = labelAbove [] (Element.text "New content") 130 | } 131 | , Element.map NewTag (Tags.view viewTag "New tag" "Add tag" model.newTags) 132 | , Component.button SubmitContent "Add content" 133 | ] 134 | ] 135 | 136 | 137 | 138 | -- HTTP 139 | 140 | 141 | retrieveUrl : Set Tag -> String 142 | retrieveUrl tags = 143 | Url.Builder.custom 144 | (CrossOrigin "http://localhost:8080") 145 | [ "get-contents" ] 146 | (List.map (\tag -> Url.Builder.string "tag" tag) (toList tags)) 147 | Nothing 148 | 149 | 150 | authorization : Token -> Header 151 | authorization token = 152 | Http.header "Authorization" (String.append "Bearer " token) 153 | 154 | 155 | retrieveContents : Token -> Set Tag -> Cmd Msg 156 | retrieveContents token tags = 157 | Http.request 158 | { method = "GET" 159 | , headers = [ authorization token ] 160 | , url = retrieveUrl tags 161 | , body = emptyBody 162 | , expect = expectJson handleContentsResponse (Json.Decode.list wrappedContentDecoder) 163 | , timeout = Nothing 164 | , tracker = Nothing 165 | } 166 | 167 | 168 | handleContentsResponse : Result Http.Error (List Content) -> Msg 169 | handleContentsResponse result = 170 | case result of 171 | Ok value -> 172 | FetchSuccessful value 173 | 174 | Err error -> 175 | FetchFailed error 176 | 177 | 178 | tagDecoder : Decoder Tag 179 | tagDecoder = 180 | field "name" Json.Decode.string 181 | 182 | 183 | contentDecoder : Decoder Content 184 | contentDecoder = 185 | map2 Content 186 | (field "message" Json.Decode.string) 187 | (field "tags" (Json.Decode.map fromList (Json.Decode.list Json.Decode.string))) 188 | 189 | 190 | wrappedContentDecoder : Decoder Content 191 | wrappedContentDecoder = 192 | Json.Decode.map identity 193 | (field "content" contentDecoder) 194 | 195 | 196 | addContent : Token -> Content -> Cmd Msg 197 | addContent token content = 198 | Http.request 199 | { method = "POST" 200 | , headers = [ authorization token ] 201 | , url = "http://localhost:8080/add-content" 202 | , body = jsonBody (contentEncoder content) 203 | , expect = expectWhatever (handleNewContentResponse content) 204 | , timeout = Nothing 205 | , tracker = Nothing 206 | } 207 | 208 | 209 | handleNewContentResponse : Content -> Result Http.Error () -> Msg 210 | handleNewContentResponse content result = 211 | case result of 212 | Err _ -> 213 | SubmitFailed 214 | 215 | Ok () -> 216 | SubmitSuccessful content 217 | 218 | 219 | tagEncoder : Tag -> Json.Encode.Value 220 | tagEncoder tag = 221 | Json.Encode.string tag 222 | 223 | 224 | contentEncoder : Content -> Json.Encode.Value 225 | contentEncoder content = 226 | Json.Encode.object 227 | [ ( "message", Json.Encode.string content.message ) 228 | , ( "tags", Json.Encode.list tagEncoder (toList content.tags) ) 229 | ] 230 | -------------------------------------------------------------------------------- /elm/src/LoggedModel.elm: -------------------------------------------------------------------------------- 1 | module LoggedModel exposing (..) 2 | 3 | import Set exposing (..) 4 | 5 | 6 | type alias Tag = 7 | String 8 | 9 | 10 | type alias Content = 11 | { message : String 12 | , tags : Set Tag 13 | } 14 | -------------------------------------------------------------------------------- /elm/src/Main.elm: -------------------------------------------------------------------------------- 1 | module Main exposing (..) 2 | 3 | import Anonymous exposing (..) 4 | import Browser exposing (..) 5 | import Credentials exposing (Submit(..), SubmitMessage(..)) 6 | import Element exposing (..) 7 | import Logged exposing (..) 8 | import Set exposing (..) 9 | import Style exposing (..) 10 | import Tuple exposing (mapBoth) 11 | 12 | 13 | 14 | -- MAIN 15 | 16 | 17 | main : Program () Model Msg 18 | main = 19 | element 20 | { init = init 21 | , view = Element.layout [] << view 22 | , update = update 23 | , subscriptions = subscriptions 24 | } 25 | 26 | 27 | 28 | -- MODEL 29 | 30 | 31 | type Model 32 | = Anonymous Anonymous.Model 33 | | LoggedIn Logged.Model 34 | 35 | 36 | init : () -> ( Model, Cmd Msg ) 37 | init _ = 38 | Tuple.mapBoth Anonymous (Cmd.map AnonymousMsg) (Anonymous.init ()) 39 | 40 | 41 | 42 | -- UPDATE 43 | 44 | 45 | type Msg 46 | = AnonymousMsg Anonymous.Msg 47 | | LoggedInMsg Logged.Msg 48 | 49 | 50 | updateAnonymous : Anonymous.Msg -> Anonymous.Model -> ( Model, Cmd Msg ) 51 | updateAnonymous msg anonymousModel = 52 | case msg of 53 | Login (Succeeded token) -> 54 | ( LoggedIn (Logged.init token), Cmd.map LoggedInMsg (retrieveContents token empty) ) 55 | 56 | _ -> 57 | Tuple.mapBoth Anonymous (Cmd.map AnonymousMsg) (Anonymous.update msg anonymousModel) 58 | 59 | 60 | update : Msg -> Model -> ( Model, Cmd Msg ) 61 | update msg model = 62 | case ( msg, model ) of 63 | ( AnonymousMsg anonymousMsg, Anonymous anonymousModel ) -> 64 | updateAnonymous anonymousMsg anonymousModel 65 | 66 | ( LoggedInMsg loggedMsg, LoggedIn logged ) -> 67 | mapBoth LoggedIn (Cmd.map LoggedInMsg) (Logged.update loggedMsg logged) 68 | 69 | _ -> 70 | ( model, Cmd.none ) 71 | 72 | 73 | 74 | -- SUBSCRIPTIONS 75 | 76 | 77 | subscriptions : Model -> Sub Msg 78 | subscriptions _ = 79 | Sub.none 80 | 81 | 82 | 83 | -- VIEW 84 | 85 | 86 | view : Model -> Element Msg 87 | view model = 88 | Element.column 89 | [ Element.width fill 90 | ] 91 | [ Element.el 92 | [ titleFont 93 | , bigPadding 94 | , centerX 95 | ] 96 | (Element.text "Tagger") 97 | , case model of 98 | Anonymous anonymousModel -> 99 | Element.map AnonymousMsg (Anonymous.view anonymousModel) 100 | 101 | LoggedIn logged -> 102 | Element.map LoggedInMsg (Logged.view logged) 103 | ] 104 | -------------------------------------------------------------------------------- /elm/src/Style.elm: -------------------------------------------------------------------------------- 1 | module Style exposing (..) 2 | 3 | import Element exposing (..) 4 | import Element.Background exposing (..) 5 | import Element.Border exposing (..) 6 | import Element.Font exposing (..) 7 | 8 | 9 | 10 | -- COLORS 11 | 12 | 13 | blue : Color 14 | blue = 15 | rgb255 230 230 250 16 | 17 | 18 | purple : Color 19 | purple = 20 | rgb255 200 200 250 21 | 22 | 23 | 24 | -- FONT SIZES 25 | 26 | 27 | titleFont : Attr decorative msg 28 | titleFont = 29 | Element.Font.size 40 30 | 31 | 32 | headerFont : Attr decorative msg 33 | headerFont = 34 | Element.Font.size 25 35 | 36 | 37 | 38 | -- SPACING 39 | 40 | 41 | normalSpacing : Attribute msg 42 | normalSpacing = 43 | Element.spacing 10 44 | 45 | 46 | bigSpacing : Attribute msg 47 | bigSpacing = 48 | Element.spacing 20 49 | 50 | 51 | 52 | -- PADDING 53 | 54 | 55 | normalPadding : Attribute msg 56 | normalPadding = 57 | padding 10 58 | 59 | 60 | bigPadding : Attribute msg 61 | bigPadding = 62 | padding 20 63 | 64 | 65 | 66 | -- BUTTON STYLE 67 | 68 | 69 | buttonStyle : List (Attribute msg) 70 | buttonStyle = 71 | [ Element.Background.color blue 72 | , Element.Border.color purple 73 | , Element.Border.width 2 74 | , Element.Border.rounded 10 75 | ] 76 | 77 | 78 | tableRowStyle : List (Attribute msg) 79 | tableRowStyle = 80 | [ Element.Border.solid 81 | , Element.Border.widthEach { bottom = 1, top = 0, left = 0, right = 0 } 82 | , height fill 83 | ] 84 | -------------------------------------------------------------------------------- /elm/src/Tags.elm: -------------------------------------------------------------------------------- 1 | module Tags exposing (..) 2 | 3 | import Component exposing (..) 4 | import Element exposing (..) 5 | import Element.Background exposing (..) 6 | import Element.Border exposing (..) 7 | import Element.Events exposing (..) 8 | import Element.Input exposing (labelAbove, placeholder) 9 | import LoggedModel exposing (..) 10 | import Set exposing (..) 11 | import Style exposing (..) 12 | 13 | 14 | 15 | -- MODEL 16 | 17 | 18 | type alias Model = 19 | { newTag : String 20 | , tags : Set Tag 21 | } 22 | 23 | 24 | init : Model 25 | init = 26 | Model "" empty 27 | 28 | 29 | 30 | -- UPDATE 31 | 32 | 33 | type Msg 34 | = NewTag String 35 | | Submit 36 | | Remove String 37 | 38 | 39 | update : (Set Tag -> Cmd msg) -> Msg -> Model -> ( Model, Cmd msg ) 40 | update onSubmit msg model = 41 | case msg of 42 | NewTag newTag -> 43 | ( { model | newTag = newTag }, Cmd.none ) 44 | 45 | Submit -> 46 | let 47 | tags = 48 | insert model.newTag model.tags 49 | in 50 | ( { model | newTag = "", tags = tags }, onSubmit tags ) 51 | 52 | Remove id -> 53 | let 54 | tags = 55 | remove id model.tags 56 | in 57 | ( { model | tags = tags }, onSubmit tags ) 58 | 59 | 60 | 61 | -- VIEW 62 | 63 | 64 | removable : String -> Element Msg -> Element Msg 65 | removable id element = 66 | row 67 | [ normalSpacing ] 68 | [ element 69 | , Element.el 70 | (onClick (Remove id) :: buttonStyle) 71 | (Element.text "x") 72 | ] 73 | 74 | 75 | viewRemovableTag : (Tag -> Element Msg) -> Tag -> Element Msg 76 | viewRemovableTag viewTag tag = 77 | removable tag (viewTag tag) 78 | 79 | 80 | view : (Tag -> Element Msg) -> String -> String -> Model -> Element Msg 81 | view viewTag label submitText model = 82 | column 83 | [ normalSpacing 84 | , Element.centerX 85 | ] 86 | [ Element.el [] 87 | (Element.Input.text [] 88 | { onChange = NewTag 89 | , text = model.newTag 90 | , placeholder = Just (placeholder [] (Element.text label)) 91 | , label = labelAbove [] (Element.text label) 92 | } 93 | ) 94 | , Component.button Submit submitText 95 | , Element.row [ normalSpacing ] (List.map (viewRemovableTag viewTag) (toList model.tags)) 96 | ] 97 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-compat": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1696426674, 7 | "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=", 8 | "owner": "edolstra", 9 | "repo": "flake-compat", 10 | "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "edolstra", 15 | "repo": "flake-compat", 16 | "type": "github" 17 | } 18 | }, 19 | "flake-utils": { 20 | "inputs": { 21 | "systems": "systems" 22 | }, 23 | "locked": { 24 | "lastModified": 1701680307, 25 | "narHash": "sha256-kAuep2h5ajznlPMD9rnQyffWG8EM/C73lejGofXvdM8=", 26 | "owner": "numtide", 27 | "repo": "flake-utils", 28 | "rev": "4022d587cbbfd70fe950c1e2083a02621806a725", 29 | "type": "github" 30 | }, 31 | "original": { 32 | "owner": "numtide", 33 | "repo": "flake-utils", 34 | "type": "github" 35 | } 36 | }, 37 | "flake-utils_2": { 38 | "inputs": { 39 | "systems": "systems_2" 40 | }, 41 | "locked": { 42 | "lastModified": 1701680307, 43 | "narHash": "sha256-kAuep2h5ajznlPMD9rnQyffWG8EM/C73lejGofXvdM8=", 44 | "owner": "numtide", 45 | "repo": "flake-utils", 46 | "rev": "4022d587cbbfd70fe950c1e2083a02621806a725", 47 | "type": "github" 48 | }, 49 | "original": { 50 | "owner": "numtide", 51 | "repo": "flake-utils", 52 | "type": "github" 53 | } 54 | }, 55 | "gitignore": { 56 | "inputs": { 57 | "nixpkgs": [ 58 | "pre-commit-hooks", 59 | "nixpkgs" 60 | ] 61 | }, 62 | "locked": { 63 | "lastModified": 1703887061, 64 | "narHash": "sha256-gGPa9qWNc6eCXT/+Z5/zMkyYOuRZqeFZBDbopNZQkuY=", 65 | "owner": "hercules-ci", 66 | "repo": "gitignore.nix", 67 | "rev": "43e1aa1308018f37118e34d3a9cb4f5e75dc11d5", 68 | "type": "github" 69 | }, 70 | "original": { 71 | "owner": "hercules-ci", 72 | "repo": "gitignore.nix", 73 | "type": "github" 74 | } 75 | }, 76 | "nixpkgs": { 77 | "locked": { 78 | "lastModified": 1705133751, 79 | "narHash": "sha256-rCIsyE80jgiOU78gCWN3A0wE0tR2GI5nH6MlS+HaaSQ=", 80 | "owner": "NixOS", 81 | "repo": "nixpkgs", 82 | "rev": "9b19f5e77dd906cb52dade0b7bd280339d2a1f3d", 83 | "type": "github" 84 | }, 85 | "original": { 86 | "id": "nixpkgs", 87 | "ref": "nixos-unstable", 88 | "type": "indirect" 89 | } 90 | }, 91 | "nixpkgs-stable": { 92 | "locked": { 93 | "lastModified": 1704874635, 94 | "narHash": "sha256-YWuCrtsty5vVZvu+7BchAxmcYzTMfolSPP5io8+WYCg=", 95 | "owner": "NixOS", 96 | "repo": "nixpkgs", 97 | "rev": "3dc440faeee9e889fe2d1b4d25ad0f430d449356", 98 | "type": "github" 99 | }, 100 | "original": { 101 | "owner": "NixOS", 102 | "ref": "nixos-23.11", 103 | "repo": "nixpkgs", 104 | "type": "github" 105 | } 106 | }, 107 | "nixpkgs_2": { 108 | "locked": { 109 | "lastModified": 1704842529, 110 | "narHash": "sha256-OTeQA+F8d/Evad33JMfuXC89VMetQbsU4qcaePchGr4=", 111 | "owner": "NixOS", 112 | "repo": "nixpkgs", 113 | "rev": "eabe8d3eface69f5bb16c18f8662a702f50c20d5", 114 | "type": "github" 115 | }, 116 | "original": { 117 | "owner": "NixOS", 118 | "ref": "nixpkgs-unstable", 119 | "repo": "nixpkgs", 120 | "type": "github" 121 | } 122 | }, 123 | "pre-commit-hooks": { 124 | "inputs": { 125 | "flake-compat": "flake-compat", 126 | "flake-utils": "flake-utils_2", 127 | "gitignore": "gitignore", 128 | "nixpkgs": "nixpkgs_2", 129 | "nixpkgs-stable": "nixpkgs-stable" 130 | }, 131 | "locked": { 132 | "lastModified": 1705229514, 133 | "narHash": "sha256-itILy0zimR/iyUGq5Dgg0fiW8plRDyxF153LWGsg3Cw=", 134 | "owner": "cachix", 135 | "repo": "pre-commit-hooks.nix", 136 | "rev": "ffa9a5b90b0acfaa03b1533b83eaf5dead819a05", 137 | "type": "github" 138 | }, 139 | "original": { 140 | "owner": "cachix", 141 | "repo": "pre-commit-hooks.nix", 142 | "type": "github" 143 | } 144 | }, 145 | "root": { 146 | "inputs": { 147 | "flake-utils": "flake-utils", 148 | "nixpkgs": "nixpkgs", 149 | "pre-commit-hooks": "pre-commit-hooks" 150 | } 151 | }, 152 | "systems": { 153 | "locked": { 154 | "lastModified": 1681028828, 155 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 156 | "owner": "nix-systems", 157 | "repo": "default", 158 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 159 | "type": "github" 160 | }, 161 | "original": { 162 | "owner": "nix-systems", 163 | "repo": "default", 164 | "type": "github" 165 | } 166 | }, 167 | "systems_2": { 168 | "locked": { 169 | "lastModified": 1681028828, 170 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 171 | "owner": "nix-systems", 172 | "repo": "default", 173 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 174 | "type": "github" 175 | }, 176 | "original": { 177 | "owner": "nix-systems", 178 | "repo": "default", 179 | "type": "github" 180 | } 181 | } 182 | }, 183 | "root": "root", 184 | "version": 7 185 | } 186 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "A servant template"; 3 | 4 | inputs = { 5 | pre-commit-hooks.url = "github:cachix/pre-commit-hooks.nix"; 6 | nixpkgs.url = "nixpkgs/nixos-unstable"; 7 | flake-utils.url = "github:numtide/flake-utils"; 8 | }; 9 | 10 | outputs = { self, nixpkgs, flake-utils, pre-commit-hooks }: 11 | flake-utils.lib.eachDefaultSystem (system: 12 | let 13 | packageName = "servant-template"; 14 | pkgs = nixpkgs.legacyPackages.${system}; 15 | haskellPackages = pkgs.haskellPackages.override { 16 | overrides = self: super: rec { 17 | openapi3 = 18 | pkgs.lib.pipe super.openapi3 19 | [ 20 | pkgs.haskell.lib.unmarkBroken 21 | pkgs.haskell.lib.dontCheck 22 | ]; 23 | }; 24 | }; 25 | in 26 | { 27 | defaultPackage = self.packages.${system}.${packageName}; 28 | packages.${packageName} = 29 | haskellPackages.callCabal2nix packageName self rec { 30 | servant-auth-server = 31 | pkgs.lib.pipe haskellPackages.servant-auth-server 32 | [ 33 | pkgs.haskell.lib.unmarkBroken 34 | pkgs.haskell.lib.dontCheck 35 | ]; 36 | 37 | tomland = 38 | pkgs.lib.pipe haskellPackages.tomland 39 | [ 40 | pkgs.haskell.lib.doJailbreak 41 | pkgs.haskell.lib.dontCheck 42 | ]; 43 | }; 44 | 45 | checks = { 46 | pre-commit-check = pre-commit-hooks.lib.${system}.run { 47 | src = ./.; 48 | hooks = { 49 | hlint.enable = true; 50 | hpack.enable = true; 51 | ormolu.enable = true; 52 | nixpkgs-fmt.enable = true; 53 | }; 54 | }; 55 | }; 56 | 57 | devShells.default = pkgs.haskellPackages.shellFor rec { 58 | inherit (self.checks.${system}.pre-commit-check) shellHook; 59 | 60 | packages = p: [ self.packages.${system}.${packageName} ]; 61 | 62 | buildInputs = with pkgs; [ 63 | elmPackages.elm 64 | elmPackages.elm-format 65 | elmPackages.elm-language-server 66 | elmPackages.elm-live 67 | haskellPackages.cabal-install 68 | haskellPackages.ghcid 69 | haskellPackages.haskell-language-server 70 | haskellPackages.hspec-discover 71 | haskellPackages.ormolu 72 | hpack 73 | jq 74 | nodejs 75 | postgresql 76 | go-task 77 | toml2json 78 | watchexec 79 | zlib 80 | ]; 81 | 82 | # Ensure that libz.so and other libraries are available to TH 83 | # splices, cabal repl, etc. 84 | LD_LIBRARY_PATH = pkgs.lib.makeLibraryPath buildInputs; 85 | }; 86 | }); 87 | } 88 | -------------------------------------------------------------------------------- /hie.yaml: -------------------------------------------------------------------------------- 1 | cradle: 2 | cabal: 3 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: servant-template 2 | version: 0.1.0.0 3 | author: Marco Perone 4 | maintainer: christian.georgii@tweag.io 5 | extra-source-files: 6 | - README.md 7 | 8 | language: GHC2021 9 | 10 | ghc-options: 11 | -W 12 | -Wall 13 | -Werror 14 | -Wincomplete-uni-patterns 15 | -Wincomplete-record-updates 16 | -fwrite-ide-info 17 | -hiedir=.hie 18 | 19 | default-extensions: 20 | - DataKinds 21 | - DeriveAnyClass 22 | - DerivingStrategies 23 | - DerivingVia 24 | - DuplicateRecordFields 25 | - GADTs 26 | - LambdaCase 27 | - OverloadedRecordDot 28 | - OverloadedStrings 29 | - RecordWildCards 30 | - TypeFamilies 31 | 32 | library: 33 | source-dirs: src 34 | 35 | dependencies: 36 | - base >= 4.14 && < 5 37 | - aeson 38 | - bcrypt 39 | - bytestring 40 | - co-log-core 41 | - containers 42 | - extra 43 | - hasql 44 | - hasql-transaction 45 | - jose 46 | - lens 47 | - mtl 48 | - openapi3 49 | - optparse-applicative 50 | - postgresql-error-codes 51 | - rel8 52 | - servant 53 | - servant-auth 54 | - servant-auth-server 55 | - servant-openapi3 56 | - servant-server 57 | - text 58 | - time 59 | - tomland 60 | - transformers 61 | - uuid 62 | - wai 63 | - wai-cors 64 | - wai-extra 65 | - warp 66 | 67 | executables: 68 | servant-template-exe: 69 | source-dirs: app 70 | main: Main.hs 71 | dependencies: 72 | - servant-template 73 | 74 | tests: 75 | servant-template-spec: 76 | main: Spec.hs 77 | source-dirs: spec 78 | dependencies: 79 | - servant-template 80 | - containers 81 | - hspec 82 | - http-client 83 | - http-types 84 | - servant-auth-client 85 | - servant-client 86 | - servant-client-core 87 | - warp 88 | -------------------------------------------------------------------------------- /schema.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE users 2 | ( id UUID PRIMARY KEY 3 | , name TEXT NOT NULL UNIQUE 4 | , password TEXT NOT NULL 5 | ); 6 | 7 | CREATE TABLE contents 8 | ( id UUID PRIMARY KEY 9 | , content TEXT NOT NULL 10 | , user_id UUID REFERENCES users (id) ON DELETE CASCADE ON UPDATE CASCADE 11 | ); 12 | 13 | CREATE TABLE tags 14 | ( id UUID PRIMARY KEY 15 | , name TEXT NOT NULL UNIQUE 16 | ); 17 | 18 | CREATE TABLE contents_tags 19 | ( content_id UUID REFERENCES contents (id) ON DELETE CASCADE ON UPDATE CASCADE 20 | , tag_id UUID REFERENCES tags (id) ON DELETE CASCADE ON UPDATE CASCADE 21 | ); 22 | -------------------------------------------------------------------------------- /scripts/db/destroy: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | pkill postgres 4 | rm -rf ./.postgres 5 | -------------------------------------------------------------------------------- /scripts/db/setup: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | dbuser=$(toml2json $PWD/config.toml | jq .database.user -r) 4 | dbport=$(toml2json $PWD/config.toml | jq .database.port -r) 5 | dbname=$(toml2json $PWD/config.toml | jq .database.dbname -r) 6 | 7 | export PGHOST=$PWD/.postgres 8 | export PGDATA=$PGHOST/data 9 | export PGDATABASE=postgres 10 | export PGLOG=$PGHOST/postgres.log 11 | export PGPORT=$dbport 12 | 13 | mkdir -p $PGHOST 14 | 15 | if [ ! -d $PGDATA ]; then 16 | initdb --auth=trust --no-locale --encoding=UTF8 > /dev/null 17 | fi 18 | 19 | if ! pg_ctl status > /dev/null 20 | then 21 | pg_ctl start -l $PGLOG -o "--unix_socket_directories='$PGHOST'" 22 | 23 | echo "[DB] Creating database \"$dbname\"..." 24 | psql --command "create database \"$dbname\"" 25 | 26 | echo "[DB] Creating user \"$dbuser\"..." 27 | psql --command "create user \"$dbuser\"" 28 | 29 | echo "[DB] Granting privileges to \"$dbuser\"..." 30 | psql --command "grant all privileges on database \"$dbname\" to \"$dbuser\";" 31 | psql -d "$dbname" --command "grant all on schema public to \"$dbuser\"" 32 | 33 | echo "[DB] Applying schema..." 34 | psql -U "$dbuser" -d "$dbname" -f ./schema.sql; 35 | fi 36 | 37 | echo "DB setup complete." 38 | -------------------------------------------------------------------------------- /servant-template.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: servant-template 8 | version: 0.1.0.0 9 | author: Marco Perone 10 | maintainer: christian.georgii@tweag.io 11 | license: MIT 12 | license-file: LICENSE 13 | build-type: Simple 14 | extra-source-files: 15 | README.md 16 | 17 | library 18 | exposed-modules: 19 | API.Application 20 | API.AppServices 21 | API.Authentication 22 | API.Config 23 | API.Docs 24 | API.Healthcheck 25 | API.Tagger 26 | App 27 | CLIOptions 28 | Dependencies 29 | Impl.Authentication.Authenticator 30 | Impl.Repository.Content 31 | Impl.Repository.Content.InMemory 32 | Impl.Repository.Content.Postgres 33 | Impl.Repository.User 34 | Impl.Repository.User.Error 35 | Impl.Repository.User.InMemory 36 | Impl.Repository.User.Postgres 37 | Infrastructure.Authentication.PasswordManager 38 | Infrastructure.Authentication.Token 39 | Infrastructure.Database 40 | Infrastructure.Logging.Logger 41 | Infrastructure.Persistence.Queries 42 | Infrastructure.Persistence.Schema 43 | Infrastructure.Persistence.Serializer 44 | Infrastructure.SystemTime 45 | Middleware 46 | Tagger.Authentication.Authenticator 47 | Tagger.Authentication.Credentials 48 | Tagger.Content 49 | Tagger.EncryptedPassword 50 | Tagger.Id 51 | Tagger.JSONWebKey 52 | Tagger.Owned 53 | Tagger.Repository.Content 54 | Tagger.Repository.User 55 | Tagger.Tag 56 | Tagger.User 57 | other-modules: 58 | Paths_servant_template 59 | hs-source-dirs: 60 | src 61 | default-extensions: 62 | DataKinds 63 | DeriveAnyClass 64 | DerivingStrategies 65 | DerivingVia 66 | DuplicateRecordFields 67 | GADTs 68 | LambdaCase 69 | OverloadedRecordDot 70 | OverloadedStrings 71 | RecordWildCards 72 | TypeFamilies 73 | ghc-options: -W -Wall -Werror -Wincomplete-uni-patterns -Wincomplete-record-updates -fwrite-ide-info -hiedir=.hie 74 | build-depends: 75 | aeson 76 | , base >=4.14 && <5 77 | , bcrypt 78 | , bytestring 79 | , co-log-core 80 | , containers 81 | , extra 82 | , hasql 83 | , hasql-transaction 84 | , jose 85 | , lens 86 | , mtl 87 | , openapi3 88 | , optparse-applicative 89 | , postgresql-error-codes 90 | , rel8 91 | , servant 92 | , servant-auth 93 | , servant-auth-server 94 | , servant-openapi3 95 | , servant-server 96 | , text 97 | , time 98 | , tomland 99 | , transformers 100 | , uuid 101 | , wai 102 | , wai-cors 103 | , wai-extra 104 | , warp 105 | default-language: GHC2021 106 | 107 | executable servant-template-exe 108 | main-is: Main.hs 109 | other-modules: 110 | Paths_servant_template 111 | hs-source-dirs: 112 | app 113 | default-extensions: 114 | DataKinds 115 | DeriveAnyClass 116 | DerivingStrategies 117 | DerivingVia 118 | DuplicateRecordFields 119 | GADTs 120 | LambdaCase 121 | OverloadedRecordDot 122 | OverloadedStrings 123 | RecordWildCards 124 | TypeFamilies 125 | ghc-options: -W -Wall -Werror -Wincomplete-uni-patterns -Wincomplete-record-updates -fwrite-ide-info -hiedir=.hie 126 | build-depends: 127 | aeson 128 | , base >=4.14 && <5 129 | , bcrypt 130 | , bytestring 131 | , co-log-core 132 | , containers 133 | , extra 134 | , hasql 135 | , hasql-transaction 136 | , jose 137 | , lens 138 | , mtl 139 | , openapi3 140 | , optparse-applicative 141 | , postgresql-error-codes 142 | , rel8 143 | , servant 144 | , servant-auth 145 | , servant-auth-server 146 | , servant-openapi3 147 | , servant-server 148 | , servant-template 149 | , text 150 | , time 151 | , tomland 152 | , transformers 153 | , uuid 154 | , wai 155 | , wai-cors 156 | , wai-extra 157 | , warp 158 | default-language: GHC2021 159 | 160 | test-suite servant-template-spec 161 | type: exitcode-stdio-1.0 162 | main-is: Spec.hs 163 | other-modules: 164 | TaggerSpec 165 | TestServices 166 | Paths_servant_template 167 | hs-source-dirs: 168 | spec 169 | default-extensions: 170 | DataKinds 171 | DeriveAnyClass 172 | DerivingStrategies 173 | DerivingVia 174 | DuplicateRecordFields 175 | GADTs 176 | LambdaCase 177 | OverloadedRecordDot 178 | OverloadedStrings 179 | RecordWildCards 180 | TypeFamilies 181 | ghc-options: -W -Wall -Werror -Wincomplete-uni-patterns -Wincomplete-record-updates -fwrite-ide-info -hiedir=.hie 182 | build-depends: 183 | aeson 184 | , base >=4.14 && <5 185 | , bcrypt 186 | , bytestring 187 | , co-log-core 188 | , containers 189 | , extra 190 | , hasql 191 | , hasql-transaction 192 | , hspec 193 | , http-client 194 | , http-types 195 | , jose 196 | , lens 197 | , mtl 198 | , openapi3 199 | , optparse-applicative 200 | , postgresql-error-codes 201 | , rel8 202 | , servant 203 | , servant-auth 204 | , servant-auth-client 205 | , servant-auth-server 206 | , servant-client 207 | , servant-client-core 208 | , servant-openapi3 209 | , servant-server 210 | , servant-template 211 | , text 212 | , time 213 | , tomland 214 | , transformers 215 | , uuid 216 | , wai 217 | , wai-cors 218 | , wai-extra 219 | , warp 220 | default-language: GHC2021 221 | -------------------------------------------------------------------------------- /spec/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /spec/TaggerSpec.hs: -------------------------------------------------------------------------------- 1 | module TaggerSpec where 2 | 3 | import API.Application (API, ApplicationAPI (..), app) 4 | import API.Authentication (AuthenticationAPI (..)) 5 | import API.Tagger (TaggerAPI (..)) 6 | import Data.ByteString.Lazy (toStrict) 7 | import Data.Either (isRight) 8 | import Data.Proxy (Proxy (Proxy)) 9 | import Infrastructure.Authentication.Token (Token (Token)) 10 | import Network.HTTP.Client (defaultManagerSettings, newManager) 11 | import Network.HTTP.Types.Status (Status, forbidden403, unauthorized401) 12 | import Network.Wai.Handler.Warp (Port, testWithApplication) 13 | import Servant.Auth.Client.Internal qualified as Servant (Token (Token)) 14 | import Servant.Client (ClientEnv, ClientM, HasClient (Client), baseUrlPort, client, mkClientEnv, parseBaseUrl, runClientM) 15 | import Servant.Client.Core (ClientError (..), responseStatusCode) 16 | import Tagger.Authentication.Credentials (Credentials (Credentials), Password (Password)) 17 | import Tagger.Content (Content, createContent) 18 | import Tagger.Id (Id) 19 | import Tagger.Owned (Owned (Owned)) 20 | import Tagger.Tag (Tag (Tag)) 21 | import Tagger.User (User) 22 | import Test.Hspec (Spec, around, describe, it, runIO, shouldMatchList, shouldSatisfy) 23 | import TestServices (testServices) 24 | import Prelude hiding (getContents) 25 | 26 | withTaggerApp :: (Port -> IO ()) -> IO () 27 | withTaggerApp = testWithApplication $ app <$> testServices 28 | 29 | hasStatus :: Status -> Either ClientError a -> Bool 30 | hasStatus status = \case 31 | (Left (FailureResponse _ response)) -> responseStatusCode response == status 32 | _ -> False 33 | 34 | toServantToken :: Token -> Servant.Token 35 | toServantToken (Token token) = Servant.Token (toStrict token) 36 | 37 | apiClient :: Client ClientM API 38 | apiClient = client (Proxy :: Proxy API) 39 | 40 | registerUser :: ClientEnv -> Credentials -> IO (Either ClientError (Id User)) 41 | registerUser env login' = runClientM ((register . authentication $ apiClient) login') env 42 | 43 | loginUser :: ClientEnv -> Credentials -> IO (Either ClientError (Id User, Token)) 44 | loginUser env login' = do 45 | userId <- registerUser env login' 46 | token <- runClientM ((login . authentication $ apiClient) login') env 47 | pure $ (,) <$> userId <*> token 48 | 49 | successfullyLoginUser :: ClientEnv -> Credentials -> IO (Id User, Token) 50 | successfullyLoginUser env login' = do 51 | eitherUserIdToken <- loginUser env login' 52 | either (const $ fail "no userId or token") pure eitherUserIdToken 53 | 54 | addUserContent :: ClientEnv -> Token -> Content Tag -> IO (Either ClientError (Id (Content Tag))) 55 | addUserContent env token content = runClientM ((addContent . tagger apiClient) (toServantToken token) content) env 56 | 57 | getUserContents :: ClientEnv -> Token -> [Tag] -> IO (Either ClientError [Owned (Content Tag)]) 58 | getUserContents env token tags = runClientM ((getContents . tagger apiClient) (toServantToken token) tags) env 59 | 60 | spec :: Spec 61 | spec = around withTaggerApp $ do 62 | baseUrl <- runIO $ parseBaseUrl "http://localhost" 63 | manager <- runIO $ newManager defaultManagerSettings 64 | let clientEnv port = mkClientEnv manager (baseUrl {baseUrlPort = port}) 65 | 66 | describe "Tagger" $ do 67 | describe "register user" $ do 68 | it "should register a user" $ \port -> do 69 | response <- registerUser (clientEnv port) (Credentials "marcosh" (Password "password")) 70 | response `shouldSatisfy` isRight 71 | 72 | it "should not register two users with the same name" $ \port -> do 73 | _ <- registerUser (clientEnv port) (Credentials "marcosh" (Password "password")) 74 | response <- registerUser (clientEnv port) (Credentials "marcosh" (Password "password1")) 75 | response `shouldSatisfy` hasStatus forbidden403 76 | 77 | it "should register two users with different names" $ \port -> do 78 | _ <- registerUser (clientEnv port) (Credentials "marcosh" (Password "password")) 79 | response <- registerUser (clientEnv port) (Credentials "perons" (Password "password")) 80 | response `shouldSatisfy` isRight 81 | 82 | describe "login" $ do 83 | it "generates a token for a registered user" $ \port -> do 84 | let loginData = Credentials "marcosh" (Password "password") 85 | response <- loginUser (clientEnv port) loginData 86 | response `shouldSatisfy` isRight 87 | 88 | it "does not generate a token for a non registered user" $ \port -> do 89 | let loginOperation = login . authentication $ apiClient 90 | credentials = Credentials "marcosh" (Password "password") 91 | 92 | response <- runClientM (loginOperation credentials) (clientEnv port) 93 | response `shouldSatisfy` hasStatus unauthorized401 94 | 95 | describe "addContent" $ do 96 | it "allows a user to add a new content" $ \port -> do 97 | let loginData = Credentials "marcosh" (Password "password") 98 | token <- snd <$> successfullyLoginUser (clientEnv port) loginData 99 | let content = createContent "some content" [Tag "first tag", Tag "second tag"] 100 | response <- addUserContent (clientEnv port) token content 101 | response `shouldSatisfy` isRight 102 | 103 | describe "getContents" $ do 104 | it "retrieves all contents added by a user" $ \port -> do 105 | let loginData = Credentials "marcosh" (Password "password") 106 | (userId, token) <- successfullyLoginUser (clientEnv port) loginData 107 | let content1 = createContent "some content" [Tag "first tag", Tag "second tag"] 108 | let content2 = createContent "other content" [Tag "first tag", Tag "third tag"] 109 | _ <- addUserContent (clientEnv port) token content1 110 | _ <- addUserContent (clientEnv port) token content2 111 | contents <- getUserContents (clientEnv port) token [] 112 | case contents of 113 | Left _ -> fail "unable to retrieve contents" 114 | Right ownedContent -> ownedContent `shouldMatchList` [Owned userId content1, Owned userId content2] 115 | 116 | it "retrieves all contents with a shared tag" $ \port -> do 117 | let loginData = Credentials "marcosh" (Password "password") 118 | (userId, token) <- successfullyLoginUser (clientEnv port) loginData 119 | let content1 = createContent "some content" [Tag "first tag", Tag "second tag"] 120 | let content2 = createContent "other content" [Tag "first tag", Tag "third tag"] 121 | _ <- addUserContent (clientEnv port) token content1 122 | _ <- addUserContent (clientEnv port) token content2 123 | contents <- getUserContents (clientEnv port) token [Tag "first tag"] 124 | case contents of 125 | Left _ -> fail "unable to retrieve contents" 126 | Right ownedContent -> ownedContent `shouldMatchList` [Owned userId content1, Owned userId content2] 127 | 128 | it "retrieves only contents with a given tag" $ \port -> do 129 | let loginData = Credentials "marcosh" (Password "password") 130 | (userId, token) <- successfullyLoginUser (clientEnv port) loginData 131 | let content1 = createContent "some content" [Tag "first tag", Tag "second tag"] 132 | let content2 = createContent "other content" [Tag "first tag", Tag "third tag"] 133 | _ <- addUserContent (clientEnv port) token content1 134 | _ <- addUserContent (clientEnv port) token content2 135 | contents <- getUserContents (clientEnv port) token [Tag "second tag"] 136 | case contents of 137 | Left _ -> fail "unable to retrieve contents" 138 | Right ownedContent -> ownedContent `shouldMatchList` [Owned userId content1] 139 | 140 | it "does not retrieve contents with non existing mix of tags" $ \port -> do 141 | let loginData = Credentials "marcosh" (Password "password") 142 | (_, token) <- successfullyLoginUser (clientEnv port) loginData 143 | let content1 = createContent "some content" [Tag "first tag", Tag "second tag"] 144 | let content2 = createContent "other content" [Tag "first tag", Tag "third tag"] 145 | _ <- addUserContent (clientEnv port) token content1 146 | _ <- addUserContent (clientEnv port) token content2 147 | contents <- getUserContents (clientEnv port) token [Tag "second tag", Tag "third tag"] 148 | case contents of 149 | Left _ -> fail "unable to retrieve contents" 150 | Right ownedContent -> ownedContent `shouldMatchList` [] 151 | 152 | it "retrieves contents with all the required tags" $ \port -> do 153 | let loginData = Credentials "marcosh" (Password "password") 154 | (userId, token) <- successfullyLoginUser (clientEnv port) loginData 155 | let content1 = createContent "some content" [Tag "first tag", Tag "second tag"] 156 | let content2 = createContent "other content" [Tag "first tag", Tag "third tag"] 157 | _ <- addUserContent (clientEnv port) token content1 158 | _ <- addUserContent (clientEnv port) token content2 159 | contents <- getUserContents (clientEnv port) token [Tag "first tag", Tag "second tag"] 160 | case contents of 161 | Left _ -> fail "unable to retrieve contents" 162 | Right ownedContent -> ownedContent `shouldMatchList` [Owned userId content1] 163 | 164 | it "retrieves only contents from the requesting user" $ \port -> do 165 | let loginData1 = Credentials "marcosh" (Password "password") 166 | (userId1, token1) <- successfullyLoginUser (clientEnv port) loginData1 167 | let content1 = createContent "first content" [Tag "first tag", Tag "second tag"] 168 | let content2 = createContent "second content" [Tag "first tag", Tag "third tag"] 169 | _ <- addUserContent (clientEnv port) token1 content1 170 | _ <- addUserContent (clientEnv port) token1 content2 171 | let loginData2 = Credentials "perons" (Password "password") 172 | (_, token2) <- successfullyLoginUser (clientEnv port) loginData2 173 | let content3 = createContent "third content" [Tag "first tag", Tag "second tag"] 174 | let content4 = createContent "fourth content" [Tag "first tag", Tag "third tag"] 175 | _ <- addUserContent (clientEnv port) token2 content3 176 | _ <- addUserContent (clientEnv port) token2 content4 177 | contents <- getUserContents (clientEnv port) token1 [Tag "first tag"] 178 | case contents of 179 | Left _ -> fail "unable to retrieve contents" 180 | Right ownedContent -> ownedContent `shouldMatchList` [Owned userId1 content1, Owned userId1 content2] 181 | -------------------------------------------------------------------------------- /spec/TestServices.hs: -------------------------------------------------------------------------------- 1 | module TestServices where 2 | 3 | import API.AppServices (AppServices (..), connectedAuthenticateUser, connectedContentRepository, connectedUserRepository, encryptedPasswordManager) 4 | import GHC.Conc (newTVarIO) 5 | import Impl.Repository.Content qualified as Repo.Content 6 | import Impl.Repository.User qualified as Repo.User 7 | import Infrastructure.Logging.Logger as Logger 8 | import Infrastructure.SystemTime as SystemTime 9 | import Servant.Auth.Server (defaultJWTSettings, generateKey) 10 | 11 | testServices :: IO AppServices 12 | testServices = do 13 | key <- generateKey 14 | userMap <- newTVarIO mempty 15 | contentsMap <- newTVarIO mempty 16 | SystemTime.withHandle $ \timeHandle -> 17 | Logger.withHandle timeHandle $ \loggerHandle -> do 18 | let passwordManager' = encryptedPasswordManager loggerHandle $ defaultJWTSettings key 19 | let userRepository' = Repo.User.inMemory userMap 20 | let contentsRepository = Repo.Content.inMemory contentsMap 21 | pure $ 22 | AppServices 23 | { jwtSettings = defaultJWTSettings key, 24 | passwordManager = passwordManager', 25 | contentRepository = connectedContentRepository loggerHandle contentsRepository, 26 | userRepository = connectedUserRepository loggerHandle userRepository', 27 | authenticateUser = connectedAuthenticateUser loggerHandle userRepository' passwordManager' 28 | } 29 | -------------------------------------------------------------------------------- /src/API/AppServices.hs: -------------------------------------------------------------------------------- 1 | module API.AppServices where 2 | 3 | import Control.Monad ((<=<)) 4 | import Control.Monad.Except (throwError) 5 | import Control.Monad.IO.Class (liftIO) 6 | import Control.Monad.Trans.Except (ExceptT, runExceptT) 7 | import Crypto.JOSE.JWK (JWK) 8 | import Hasql.Session (QueryError) 9 | import Impl.Authentication.Authenticator qualified as Auth 10 | import Impl.Repository.Content as Repo.Content 11 | import Impl.Repository.User qualified as Repo.User 12 | import Impl.Repository.User.Error (UserRepositoryError (..)) 13 | import Infrastructure.Authentication.PasswordManager (PasswordManager, PasswordManagerError (..), bcryptPasswordManager) 14 | import Infrastructure.Authentication.PasswordManager qualified as PasswordManager 15 | import Infrastructure.Database qualified as DB 16 | import Infrastructure.Logging.Logger (logError, logWarning, withContext) 17 | import Infrastructure.Logging.Logger qualified as Logger 18 | import Infrastructure.Persistence.Queries (WrongNumberOfResults (..)) 19 | import Servant (Handler, err401, err403, err500) 20 | import Servant.Auth.Server (JWTSettings, defaultJWTSettings) 21 | import Tagger.Authentication.Authenticator qualified as Auth 22 | import Tagger.Repository.Content (ContentRepository) 23 | import Tagger.Repository.Content qualified as ContentRepository 24 | import Tagger.Repository.User (UserRepository) 25 | import Tagger.Repository.User qualified as UserRepository 26 | import Prelude hiding (log) 27 | 28 | -- | 29 | -- Collection of services needed by the application to work 30 | data AppServices = AppServices 31 | { jwtSettings :: JWTSettings, 32 | passwordManager :: PasswordManager Handler, 33 | contentRepository :: ContentRepository Handler, 34 | userRepository :: UserRepository Handler, 35 | authenticateUser :: Auth.Authenticator Handler 36 | } 37 | 38 | -- | 39 | -- Lifts a computation from 'ExceptT e IO' to 'Handler a' using the provided 'handleError' function 40 | eitherTToHandler :: (e -> Handler a) -> ExceptT e IO a -> Handler a 41 | eitherTToHandler handleError = either handleError pure <=< liftIO . runExceptT 42 | 43 | -- | 44 | -- Lifts a 'ContentRepository' fo the 'Handler' monad, handling all errors by logging them and returning a 500 response 45 | connectedContentRepository :: Logger.Handle -> ContentRepository (ExceptT QueryError IO) -> ContentRepository Handler 46 | connectedContentRepository logHandle = ContentRepository.hoist (eitherTToHandler $ (>> throwError err500) . logError logHandle . show) 47 | 48 | -- | 49 | -- Lifts a 'UserRepository' fo the 'Handler' monad, handling all errors by logging them and returning a 500 response 50 | connectedUserRepository :: Logger.Handle -> UserRepository (ExceptT UserRepositoryError IO) -> UserRepository Handler 51 | connectedUserRepository logHandle = UserRepository.hoist $ eitherTToHandler handleUserRepositoryError 52 | where 53 | handleUserRepositoryError :: UserRepositoryError -> Handler a 54 | -- If the database error concerns a duplicate user, we return a 403 response 55 | handleUserRepositoryError (DuplicateUserName e) = do 56 | logWarning logHandle $ show (DuplicateUserName e) 57 | throwError err403 58 | -- Otherwise, we return a 500 response 59 | handleUserRepositoryError e = do 60 | logError logHandle (show e) 61 | throwError err500 62 | 63 | -- | 64 | -- Creates an 'AuthenticateUser' service injecting its dependencies and handling errors 65 | connectedAuthenticateUser :: Logger.Handle -> UserRepository (ExceptT UserRepositoryError IO) -> PasswordManager Handler -> Auth.Authenticator Handler 66 | connectedAuthenticateUser logHandle userRepository' passwordManager' = 67 | Auth.hoist 68 | (eitherTToHandler handleAuthenticationError) 69 | (Auth.authenticator userRepository' passwordManager') 70 | where 71 | handleAuthenticationError :: Auth.Error -> Handler a 72 | -- If the user was not found, we return a 401 response 73 | handleAuthenticationError (Auth.QueryError (UnexpectedNumberOfRows NoResults)) = do 74 | throwError err401 75 | -- If there was an error at the database level, we return a 500 response 76 | handleAuthenticationError (Auth.QueryError e) = do 77 | logError logHandle $ show (Auth.QueryError e) 78 | throwError err500 79 | -- In other cases, there was an authentication error and we return a 401 response 80 | handleAuthenticationError e = do 81 | logWarning logHandle (show e) 82 | throwError err401 83 | 84 | -- | 85 | -- Creates a 'PasswordManager' service injecting its dependencies and handling errors 86 | encryptedPasswordManager :: Logger.Handle -> JWTSettings -> PasswordManager Handler 87 | encryptedPasswordManager logHandle = PasswordManager.hoist (eitherTToHandler handlePasswordManagerError) . bcryptPasswordManager 88 | where 89 | handlePasswordManagerError :: PasswordManagerError -> Handler a 90 | -- If there was a failure during password hashing, we return a 500 response 91 | handlePasswordManagerError FailedHashing = do 92 | logError logHandle $ show FailedHashing 93 | throwError err500 94 | -- In other cases, we return a 401 response 95 | handlePasswordManagerError (FailedJWTCreation e) = do 96 | logError logHandle $ show (FailedJWTCreation e) 97 | throwError err401 98 | 99 | start :: DB.Handle -> Logger.Handle -> JWK -> AppServices 100 | start dbHandle logHandle key = 101 | let logContext = flip withContext logHandle 102 | passwordManager' = encryptedPasswordManager (withContext "PasswordManager" logHandle) $ defaultJWTSettings key 103 | dbUserRepository = Repo.User.postgres dbHandle 104 | in AppServices 105 | { jwtSettings = defaultJWTSettings key, 106 | passwordManager = passwordManager', 107 | contentRepository = connectedContentRepository (logContext "ContentRepository") (Repo.Content.postgres dbHandle), 108 | userRepository = connectedUserRepository (logContext "UserRepository") dbUserRepository, 109 | authenticateUser = connectedAuthenticateUser (logContext "AuthenticateUser") dbUserRepository passwordManager' 110 | } 111 | -------------------------------------------------------------------------------- /src/API/Application.hs: -------------------------------------------------------------------------------- 1 | module API.Application where 2 | 3 | import API.AppServices (AppServices (..)) 4 | import API.Authentication (AuthenticationAPI, authenticationServer) 5 | import API.Docs (DocsAPI, docsServer) 6 | import API.Healthcheck (HealthcheckAPI, healthcheckServer) 7 | import API.Tagger (TaggerAPI, taggerServer) 8 | import Data.Proxy (Proxy (..)) 9 | import GHC.Generics (Generic) 10 | import Network.Wai (Application) 11 | import Servant (Context (EmptyContext, (:.)), Handler, err401, serveWithContext) 12 | import Servant.API (NamedRoutes, type (:>)) 13 | import Servant.API.Generic ((:-)) 14 | import Servant.Auth (Auth, JWT) 15 | import Servant.Auth.Server (AuthResult (Authenticated), ThrowAll (throwAll), defaultCookieSettings) 16 | import Servant.Server.Generic (AsServer) 17 | import Tagger.Id (Id) 18 | import Tagger.Repository.Content (ContentRepository) 19 | import Tagger.User (User) 20 | 21 | type API = NamedRoutes ApplicationAPI 22 | 23 | -- | 24 | -- Collects all the API groups exposed by the application 25 | data ApplicationAPI mode = ApplicationAPI 26 | { tagger :: mode :- Auth '[JWT] (Id User) :> NamedRoutes TaggerAPI, 27 | docs :: mode :- DocsAPI, 28 | healthcheck :: mode :- HealthcheckAPI, 29 | authentication :: mode :- NamedRoutes AuthenticationAPI 30 | } 31 | deriving stock (Generic) 32 | 33 | -- | 34 | -- For the endpoints which actually require authentication, checks whether the request provides a valid authentication token. 35 | -- Otherwise it returns a 401 response 36 | authenticatedTaggerServer :: ContentRepository Handler -> AuthResult (Id User) -> TaggerAPI AsServer 37 | authenticatedTaggerServer contentRepository = \case 38 | (Authenticated userId) -> taggerServer userId contentRepository 39 | _ -> throwAll err401 40 | 41 | -- | 42 | -- Setup all the application server, providing the services needed by the various endpoints 43 | server :: AppServices -> ApplicationAPI AsServer 44 | server AppServices {passwordManager, contentRepository, userRepository, authenticateUser} = 45 | ApplicationAPI 46 | { tagger = authenticatedTaggerServer contentRepository, 47 | docs = docsServer, 48 | healthcheck = healthcheckServer, 49 | authentication = authenticationServer passwordManager authenticateUser userRepository 50 | } 51 | 52 | app :: AppServices -> Application 53 | app appServices = 54 | serveWithContext 55 | (Proxy :: Proxy API) 56 | (defaultCookieSettings :. jwtSettings appServices :. EmptyContext) 57 | (server appServices) 58 | -------------------------------------------------------------------------------- /src/API/Authentication.hs: -------------------------------------------------------------------------------- 1 | module API.Authentication where 2 | 3 | import GHC.Generics (Generic) 4 | import Infrastructure.Authentication.PasswordManager (PasswordManager (generatePassword, generateToken)) 5 | import Infrastructure.Authentication.Token (Token) 6 | import Servant (Handler, JSON, Post, ReqBody, type (:>)) 7 | import Servant.API.Generic (type (:-)) 8 | import Servant.Server.Generic (AsServer) 9 | import Tagger.Authentication.Authenticator (Authenticator) 10 | import Tagger.Authentication.Authenticator qualified as Authenticator 11 | import Tagger.Authentication.Credentials (Credentials (username)) 12 | import Tagger.Id (Id) 13 | import Tagger.Repository.User as UserRepository 14 | import Tagger.User (User) 15 | 16 | -- | 17 | -- The endpoints required to perform authentication 18 | data AuthenticationAPI mode = AuthenticationAPI 19 | { -- | Given some 'Login' data, registers a new 'User' 20 | register :: mode :- "register" :> ReqBody '[JSON] Credentials :> Post '[JSON] (Id User), 21 | -- | Given some 'Login' data, generates an authentication token 22 | login :: mode :- "login" :> ReqBody '[JSON] Credentials :> Post '[JSON] Token 23 | } 24 | deriving stock (Generic) 25 | 26 | authenticationServer :: PasswordManager Handler -> Authenticator Handler -> UserRepository Handler -> AuthenticationAPI AsServer 27 | authenticationServer passwordManager authHandler userRepository = 28 | AuthenticationAPI 29 | { register = registerEndpoint passwordManager userRepository, 30 | login = loginEndpoint passwordManager authHandler 31 | } 32 | 33 | registerEndpoint :: PasswordManager Handler -> UserRepository Handler -> Credentials -> Handler (Id User) 34 | registerEndpoint passwordManager userRepository login' = do 35 | -- hash the password 36 | hashedPassword <- generatePassword passwordManager login' 37 | -- store the new user into the database 38 | UserRepository.add userRepository (username login') hashedPassword 39 | 40 | loginEndpoint :: PasswordManager Handler -> Authenticator Handler -> Credentials -> Handler Token 41 | loginEndpoint passwordManager authHandler login' = do 42 | -- try to authenticate the user 43 | user <- Authenticator.authUser authHandler login' 44 | -- if the user authenticated, generate an authentication token 45 | generateToken passwordManager user 46 | -------------------------------------------------------------------------------- /src/API/Config.hs: -------------------------------------------------------------------------------- 1 | module API.Config where 2 | 3 | import Control.Monad.IO.Class (MonadIO) 4 | import Data.ByteString.Char8 (ByteString, pack) 5 | import Data.Text (Text, unpack) 6 | import Toml (TomlCodec, decodeFileExact, diwrap, int, table, text, (.=)) 7 | 8 | -- | 9 | -- The whole config needed by the application 10 | data Config = Config 11 | { database :: DatabaseConfig, 12 | api :: ApiConfig 13 | } 14 | 15 | -- | 16 | -- The configuration parameters needed to expose the API 17 | newtype ApiConfig = ApiConfig 18 | { apiPort :: Port 19 | } 20 | 21 | -- | 22 | -- The configuration parameters needed to connect to a database 23 | data DatabaseConfig = DatabaseConfig 24 | { host :: Host, 25 | port :: Port, 26 | dbname :: DBName, 27 | user :: User, 28 | password :: Password 29 | } 30 | 31 | -- | 32 | -- Reads configuration file at given filepath 33 | load :: (MonadIO m, MonadFail m) => FilePath -> m Config 34 | load path = do 35 | eitherConfig <- decodeFileExact configCodec path 36 | either (\errors -> fail $ "unable to parse configuration: " <> show errors) pure eitherConfig 37 | 38 | newtype Host = Host {getHost :: Text} 39 | 40 | newtype Port = Port {getPort :: Int} 41 | deriving newtype (Show) 42 | 43 | newtype DBName = DBName {getDBName :: Text} 44 | 45 | newtype User = User {getUser :: Text} 46 | 47 | newtype Password = Password {getPassword :: Text} 48 | 49 | -- | 50 | -- Compute the connection string given a 'DatabaseConfig' 51 | connectionString :: DatabaseConfig -> ByteString 52 | connectionString DatabaseConfig {host, port, dbname, user, password} = 53 | pack $ 54 | "host=" 55 | <> unpack (getHost host) 56 | <> " " 57 | <> "port=" 58 | <> show port 59 | <> " " 60 | <> "dbname=" 61 | <> unpack (getDBName dbname) 62 | <> " " 63 | <> "user=" 64 | <> unpack (getUser user) 65 | <> " " 66 | <> "password=" 67 | <> unpack (getPassword password) 68 | 69 | -- | 70 | -- A bidirectional codec for 'DatabaseConfig' 71 | databaseConfigCodec :: TomlCodec DatabaseConfig 72 | databaseConfigCodec = 73 | DatabaseConfig 74 | <$> Toml.diwrap (Toml.text "host") 75 | .= host 76 | <*> Toml.diwrap (Toml.int "port") 77 | .= port 78 | <*> Toml.diwrap (Toml.text "dbname") 79 | .= dbname 80 | <*> Toml.diwrap (Toml.text "user") 81 | .= user 82 | <*> Toml.diwrap (Toml.text "password") 83 | .= password 84 | 85 | -- | 86 | -- A bidirectional codec for 'ApiConfig' 87 | apiConfigCodec :: TomlCodec ApiConfig 88 | apiConfigCodec = Toml.diwrap $ Toml.int "port" 89 | 90 | -- | 91 | -- A bidirectional codec for 'Config' 92 | configCodec :: TomlCodec Config 93 | configCodec = 94 | Config 95 | <$> Toml.table databaseConfigCodec "database" 96 | .= database 97 | <*> Toml.table apiConfigCodec "api" 98 | .= api 99 | -------------------------------------------------------------------------------- /src/API/Docs.hs: -------------------------------------------------------------------------------- 1 | module API.Docs where 2 | 3 | import API.Authentication (AuthenticationAPI) 4 | import API.Tagger (TaggerAPI) 5 | import Control.Lens ((&), (.~), (?~)) 6 | import Data.OpenApi (OpenApi, description, info, title, version) 7 | import Data.Proxy (Proxy (Proxy)) 8 | import Servant (Get, JSON, NamedRoutes, Server, (:>)) 9 | import Servant.OpenApi (toOpenApi) 10 | 11 | -- | 12 | -- A single endpoint to expose the OpenAPI documentation of the application 13 | type DocsAPI = "docs" :> Get '[JSON] OpenApi 14 | 15 | docsServer :: Server DocsAPI 16 | docsServer = 17 | return $ 18 | toOpenApi (Proxy :: Proxy (NamedRoutes TaggerAPI)) <> toOpenApi (Proxy :: Proxy (NamedRoutes AuthenticationAPI)) 19 | & info . title .~ "Tagger api" 20 | & info . version .~ "1.0.0" 21 | & info . description ?~ "API endpoints for the tagger API" 22 | -------------------------------------------------------------------------------- /src/API/Healthcheck.hs: -------------------------------------------------------------------------------- 1 | module API.Healthcheck where 2 | 3 | import Servant (NoContent (NoContent), Server) 4 | import Servant.API (Get, JSON, type (:>)) 5 | 6 | -- | 7 | -- A single endpoint to check the liveness of the application 8 | type HealthcheckAPI = "healthcheck" :> Get '[JSON] NoContent 9 | 10 | healthcheckServer :: Server HealthcheckAPI 11 | healthcheckServer = pure NoContent 12 | -------------------------------------------------------------------------------- /src/API/Tagger.hs: -------------------------------------------------------------------------------- 1 | module API.Tagger where 2 | 3 | import GHC.Generics (Generic) 4 | import Servant (Handler) 5 | import Servant.API (Get, JSON, Post, QueryParams, ReqBody, type (:>)) 6 | import Servant.API.Generic ((:-)) 7 | import Servant.Server.Generic (AsServer) 8 | import Tagger.Content (Content) 9 | import Tagger.Id (Id) 10 | import Tagger.Owned (Owned) 11 | import Tagger.Repository.Content (ContentRepository (addContentWithTags, selectUserContentsByTags)) 12 | import Tagger.Tag (Tag) 13 | import Tagger.User (User) 14 | import Prelude hiding (getContents) 15 | 16 | -- | 17 | -- The main endpoints of the application API 18 | data TaggerAPI mode = TaggerAPI 19 | { -- | Add a new 'Content' 20 | addContent :: mode :- "add-content" :> ReqBody '[JSON] (Content Tag) :> Post '[JSON] (Id (Content Tag)), 21 | -- | Retrieve all the 'User' 'Content's indexed by the provided 'Tag's 22 | getContents :: mode :- "get-contents" :> QueryParams "tag" Tag :> Get '[JSON] [Owned (Content Tag)] 23 | } 24 | deriving stock (Generic) 25 | 26 | taggerServer :: Id User -> ContentRepository Handler -> TaggerAPI AsServer 27 | taggerServer userId contentRepository = 28 | TaggerAPI 29 | { addContent = addContentWithTags contentRepository userId, 30 | getContents = selectUserContentsByTags contentRepository userId 31 | } 32 | -------------------------------------------------------------------------------- /src/App.hs: -------------------------------------------------------------------------------- 1 | module App where 2 | 3 | import API.AppServices as AppServices 4 | import API.Application (app) 5 | import API.Config (Port (..), apiPort) 6 | import API.Config qualified as Config 7 | import CLIOptions (CLIOptions (configPath)) 8 | import CLIOptions qualified 9 | import Dependencies (Deps (..)) 10 | import Dependencies qualified as Deps 11 | import Infrastructure.Logging.Logger qualified as Logger 12 | import Middleware qualified 13 | import Network.Wai.Handler.Warp qualified as Warp 14 | import Tagger.JSONWebKey qualified as JWK 15 | 16 | run :: IO () 17 | run = do 18 | options <- CLIOptions.parse 19 | appConfig <- Config.load $ configPath options 20 | key <- JWK.setup options 21 | 22 | Deps.withDeps appConfig $ \Deps {dbHandle, loggerHandle} -> do 23 | let (Port port) = appConfig.api.apiPort 24 | services = AppServices.start dbHandle loggerHandle key 25 | application = Middleware.apply (app services) 26 | 27 | Logger.logInfo loggerHandle $ "Starting app on port " <> show port <> "." 28 | Warp.run port application 29 | -------------------------------------------------------------------------------- /src/CLIOptions.hs: -------------------------------------------------------------------------------- 1 | module CLIOptions (CLIOptions (..), parse) where 2 | 3 | import Options.Applicative (Parser, execParser, fullDesc, help, helper, info, long, metavar, showDefault, strOption, value, (<**>)) 4 | 5 | data CLIOptions = CLIOptions 6 | { configPath :: FilePath, 7 | jwkPath :: FilePath 8 | } 9 | 10 | parse :: IO CLIOptions 11 | parse = 12 | execParser $ info (inputOptionsParser <**> helper) fullDesc 13 | 14 | inputOptionsParser :: Parser CLIOptions 15 | inputOptionsParser = 16 | CLIOptions 17 | <$> strOption 18 | ( long "config" 19 | <> metavar "CONFIG" 20 | <> help "Path for the file containing the application configuration" 21 | <> showDefault 22 | <> value "./config.toml" 23 | ) 24 | <*> strOption 25 | ( long "jwk" 26 | <> metavar "JWK" 27 | <> help "Path for the file storing the authentication key" 28 | <> showDefault 29 | <> value "./.jwk" 30 | ) 31 | -------------------------------------------------------------------------------- /src/Dependencies.hs: -------------------------------------------------------------------------------- 1 | module Dependencies (withDeps, Deps (..)) where 2 | 3 | import API.Config qualified as Config 4 | import Infrastructure.Database qualified as DB 5 | import Infrastructure.Logging.Logger qualified as Logger 6 | import Infrastructure.SystemTime qualified as SystemTime 7 | 8 | -- | 9 | -- Aggregates all effects needed by the app 10 | data Deps = Deps 11 | { systemTimeHandler :: SystemTime.Handle, 12 | loggerHandle :: Logger.Handle, 13 | dbHandle :: DB.Handle 14 | } 15 | 16 | -- | 17 | -- Starts dependencies and calls a given effectful function with them 18 | withDeps :: Config.Config -> (Deps -> IO a) -> IO a 19 | withDeps appConfig f = 20 | SystemTime.withHandle $ \systemTimeHandler -> 21 | Logger.withHandle systemTimeHandler $ \loggerHandle -> 22 | DB.withHandle appConfig $ \dbHandle -> 23 | f Deps {..} 24 | -------------------------------------------------------------------------------- /src/Impl/Authentication/Authenticator.hs: -------------------------------------------------------------------------------- 1 | module Impl.Authentication.Authenticator (Error (..), authenticator) where 2 | 3 | import Control.Monad.Trans.Except (ExceptT, throwE, withExceptT) 4 | import Impl.Repository.User.Error (UserRepositoryError) 5 | import Infrastructure.Authentication.PasswordManager (PasswordManager (validatePassword)) 6 | import Infrastructure.Persistence.Queries (WrongNumberOfResults) 7 | import Tagger.Authentication.Authenticator (Authenticator (..)) 8 | import Tagger.Authentication.Credentials (Credentials (..)) 9 | import Tagger.Id (Id) 10 | import Tagger.Repository.User as UserRepo 11 | import Tagger.User (User) 12 | 13 | authenticator :: 14 | UserRepository (ExceptT UserRepositoryError IO) -> 15 | PasswordManager n -> 16 | Authenticator (ExceptT Error IO) 17 | authenticator repo pm = 18 | Authenticator 19 | { authUser = authenticateUser repo pm 20 | } 21 | 22 | -- | 23 | -- How 'authenticateUser' can actually fail 24 | data Error 25 | = -- | the provided 'Credentials' data do not correspond to a unique user 26 | SelectUserError WrongNumberOfResults 27 | | -- | the interaction with the database somehow failed 28 | QueryError UserRepositoryError 29 | | -- | the password provided in the 'Credentials' data is not correct 30 | PasswordVerificationFailed 31 | deriving (Show) 32 | 33 | -- | 34 | -- Concrete implementation of 'AuthenticateUser'. 35 | -- Depends on a 'UserRepository' and a 'PasswordManager' 36 | authenticateUser :: UserRepository (ExceptT UserRepositoryError IO) -> PasswordManager n -> Credentials -> ExceptT Error IO (Id User) 37 | authenticateUser userRepository passwordManager Credentials {username, password} = do 38 | (userId, user) <- withExceptT QueryError $ UserRepo.findByName userRepository username 39 | -- check whether the provided password is the correct one 40 | if validatePassword passwordManager user password 41 | then pure userId 42 | else throwE PasswordVerificationFailed 43 | -------------------------------------------------------------------------------- /src/Impl/Repository/Content.hs: -------------------------------------------------------------------------------- 1 | module Impl.Repository.Content (inMemory, postgres) where 2 | 3 | import Control.Monad.Trans.Except (ExceptT) 4 | import Hasql.Session (QueryError) 5 | import Impl.Repository.Content.InMemory qualified as IM 6 | import Impl.Repository.Content.Postgres qualified as PG 7 | import Infrastructure.Database qualified as DB 8 | import Tagger.Repository.Content (ContentRepository (..)) 9 | 10 | postgres :: DB.Handle -> ContentRepository (ExceptT QueryError IO) 11 | postgres = PG.repository 12 | 13 | inMemory :: IM.Table -> ContentRepository (ExceptT QueryError IO) 14 | inMemory = IM.repository 15 | -------------------------------------------------------------------------------- /src/Impl/Repository/Content/InMemory.hs: -------------------------------------------------------------------------------- 1 | module Impl.Repository.Content.InMemory (Table, repository) where 2 | 3 | import Control.Monad.IO.Class (liftIO) 4 | import Control.Monad.Trans.Except (ExceptT) 5 | import Data.Map.Lazy (Map, elems, filter, insert) 6 | import Data.UUID.V4 (nextRandom) 7 | import GHC.Conc (TVar, atomically, readTVar, writeTVar) 8 | import Hasql.Session (QueryError) 9 | import Tagger.Content (Content, hasAllTags) 10 | import Tagger.Id (Id (Id)) 11 | import Tagger.Owned (Owned (..)) 12 | import Tagger.Repository.Content (ContentRepository (..)) 13 | import Tagger.Tag (Tag) 14 | import Tagger.User (User) 15 | import Prelude hiding (filter) 16 | 17 | type Table = TVar (Map (Id (Content Tag)) (Owned (Content Tag))) 18 | 19 | repository :: Table -> ContentRepository (ExceptT QueryError IO) 20 | repository contentsMap = 21 | ContentRepository 22 | { selectUserContentsByTags = inMemorySelectUserContentsByTags contentsMap, 23 | addContentWithTags = inMemoryAddContentWithTags contentsMap 24 | } 25 | 26 | inMemorySelectUserContentsByTags :: TVar (Map (Id (Content Tag)) (Owned (Content Tag))) -> Id User -> [Tag] -> ExceptT QueryError IO [Owned (Content Tag)] 27 | inMemorySelectUserContentsByTags contentsMap userId' tags = liftIO . atomically $ do 28 | contents <- readTVar contentsMap 29 | let userContentsWithTags = filter ((&&) <$> ((== userId') . userId) <*> (hasAllTags tags . content)) contents 30 | pure $ elems userContentsWithTags 31 | 32 | inMemoryAddContentWithTags :: TVar (Map (Id (Content Tag)) (Owned (Content Tag))) -> Id User -> Content Tag -> ExceptT QueryError IO (Id (Content Tag)) 33 | inMemoryAddContentWithTags contentsMap userId' content' = do 34 | contentId <- Id <$> liftIO nextRandom 35 | liftIO . atomically $ do 36 | contents <- readTVar contentsMap 37 | writeTVar contentsMap $ insert contentId (Owned userId' content') contents 38 | pure contentId 39 | -------------------------------------------------------------------------------- /src/Impl/Repository/Content/Postgres.hs: -------------------------------------------------------------------------------- 1 | module Impl.Repository.Content.Postgres (repository) where 2 | 3 | import Control.Monad (forM) 4 | import Control.Monad.IO.Class (liftIO) 5 | import Control.Monad.Trans.Except (ExceptT (ExceptT)) 6 | import Data.Tuple.Extra (uncurry3) 7 | import Data.UUID.V4 (nextRandom) 8 | import Hasql.Session (QueryError) 9 | import Infrastructure.Database qualified as DB 10 | import Infrastructure.Persistence.Queries qualified as DB (addContentWithTags, selectUserContents) 11 | import Infrastructure.Persistence.Serializer (serializeContent, unserializeContent) 12 | import Tagger.Content (Content, hasAllTags) 13 | import Tagger.Id (Id (Id)) 14 | import Tagger.Owned (Owned (content)) 15 | import Tagger.Repository.Content (ContentRepository (..)) 16 | import Tagger.Tag (Tag) 17 | import Tagger.User (User) 18 | 19 | -- | 20 | -- A 'ContentRepository' based on PostgreSQL 21 | repository :: DB.Handle -> ContentRepository (ExceptT QueryError IO) 22 | repository handle = 23 | ContentRepository 24 | { selectUserContentsByTags = postgresSelectUserContentsByTags handle, 25 | addContentWithTags = postgresAddContentWithTags handle 26 | } 27 | 28 | postgresSelectUserContentsByTags :: DB.Handle -> Id User -> [Tag] -> ExceptT QueryError IO [Owned (Content Tag)] 29 | postgresSelectUserContentsByTags handle userId tags = do 30 | -- Retrieve the user's contents data from the database 31 | userDBContents <- ExceptT $ DB.runQuery handle (DB.selectUserContents userId) 32 | -- Convert the contents data into their domain representation 33 | let userContents = uncurry3 unserializeContent <$> userDBContents 34 | -- Filter only the contents indexed by the provided tags 35 | pure $ filter (hasAllTags tags . content) userContents 36 | 37 | postgresAddContentWithTags :: DB.Handle -> Id User -> Content Tag -> ExceptT QueryError IO (Id (Content Tag)) 38 | postgresAddContentWithTags handle userId content' = do 39 | -- Generate a UUID for the content 40 | contentUUID <- liftIO nextRandom 41 | -- Generate and associate a UUID to every tag 42 | contentWithTagsUUIDs <- liftIO $ forM content' (\tag -> (,tag) . Id <$> nextRandom) 43 | -- Run a transaction to add the content and its tags to the database 44 | ExceptT $ DB.runQuery handle (uncurry DB.addContentWithTags $ serializeContent (Id contentUUID) userId contentWithTagsUUIDs) 45 | pure $ Id contentUUID 46 | -------------------------------------------------------------------------------- /src/Impl/Repository/User.hs: -------------------------------------------------------------------------------- 1 | module Impl.Repository.User (inMemory, postgres) where 2 | 3 | import Control.Monad.Trans.Except (ExceptT) 4 | import Impl.Repository.User.Error (UserRepositoryError) 5 | import Impl.Repository.User.InMemory qualified as IM 6 | import Impl.Repository.User.Postgres qualified as PG 7 | import Infrastructure.Database qualified as DB 8 | import Tagger.Repository.User (UserRepository (..)) 9 | 10 | postgres :: DB.Handle -> UserRepository (ExceptT UserRepositoryError IO) 11 | postgres = PG.repository 12 | 13 | inMemory :: IM.Table -> UserRepository (ExceptT UserRepositoryError IO) 14 | inMemory = IM.repository 15 | -------------------------------------------------------------------------------- /src/Impl/Repository/User/Error.hs: -------------------------------------------------------------------------------- 1 | module Impl.Repository.User.Error (UserRepositoryError (..)) where 2 | 3 | import Hasql.Session (QueryError (..)) 4 | import Infrastructure.Persistence.Queries (WrongNumberOfResults) 5 | 6 | -- We want to distinguish the `QueryError` coming from the violation of the "users_name_key" unique constraints 7 | data UserRepositoryError 8 | = DuplicateUserName QueryError 9 | | UnexpectedNumberOfRows WrongNumberOfResults 10 | | OtherError QueryError 11 | deriving (Show) 12 | -------------------------------------------------------------------------------- /src/Impl/Repository/User/InMemory.hs: -------------------------------------------------------------------------------- 1 | module Impl.Repository.User.InMemory (Table, repository) where 2 | 3 | import Control.Monad.Except (throwError) 4 | import Control.Monad.IO.Class (liftIO) 5 | import Control.Monad.Trans.Except (ExceptT) 6 | import Data.Map.Lazy (Map, assocs, filter, insert, size) 7 | import Data.Text (Text) 8 | import Data.Text.Encoding (encodeUtf8) 9 | import Data.UUID.V4 (nextRandom) 10 | import GHC.Conc (TVar, atomically, readTVar, readTVarIO, writeTVar) 11 | import Hasql.Session (CommandError (ResultError), QueryError (QueryError), ResultError (ServerError)) 12 | import Impl.Repository.User.Error (UserRepositoryError (..)) 13 | import Infrastructure.Persistence.Queries (WrongNumberOfResults (..)) 14 | import PostgreSQL.ErrorCodes (unique_violation) 15 | import Tagger.EncryptedPassword (EncryptedPassword) 16 | import Tagger.Id (Id (Id)) 17 | import Tagger.Repository.User (UserRepository (..)) 18 | import Tagger.User (User (..)) 19 | import Prelude hiding (filter) 20 | 21 | type Table = TVar (Map (Id User) User) 22 | 23 | repository :: Table -> UserRepository (ExceptT UserRepositoryError IO) 24 | repository userMap = 25 | UserRepository 26 | { findByName = inMemoryGetUserByName userMap, 27 | add = inMemoryAddUser userMap 28 | } 29 | 30 | inMemoryGetUserByName :: Table -> Text -> ExceptT UserRepositoryError IO (Id User, User) 31 | inMemoryGetUserByName userMap name' = do 32 | users <- liftIO $ readTVarIO userMap 33 | let usersWithName = filter ((== name') . name) users 34 | case size usersWithName of 35 | 0 -> throwError $ UnexpectedNumberOfRows NoResults 36 | 1 -> pure . head . assocs $ usersWithName 37 | _ -> throwError $ UnexpectedNumberOfRows MoreThanOneResult 38 | 39 | duplicateNameError :: Text -> UserRepositoryError 40 | duplicateNameError name' = 41 | DuplicateUserName $ 42 | QueryError 43 | "insert user" 44 | [] 45 | ( ResultError $ 46 | ServerError 47 | unique_violation 48 | "duplicate key value violates unique constraint" 49 | (Just $ "Key (name)=(" <> encodeUtf8 name' <> ") already exists") 50 | Nothing 51 | Nothing 52 | ) 53 | 54 | inMemoryAddUser :: Table -> Text -> EncryptedPassword -> ExceptT UserRepositoryError IO (Id User) 55 | inMemoryAddUser userMap name' password' = do 56 | userId <- Id <$> liftIO nextRandom 57 | queryError <- liftIO . atomically $ do 58 | users <- readTVar userMap 59 | let usersWithName = filter ((== name') . name) users 60 | if null usersWithName 61 | then writeTVar userMap (insert userId (User name' password') users) >> pure Nothing 62 | else pure . Just $ duplicateNameError name' 63 | case queryError of 64 | Just qe -> throwError qe 65 | Nothing -> pure userId 66 | -------------------------------------------------------------------------------- /src/Impl/Repository/User/Postgres.hs: -------------------------------------------------------------------------------- 1 | module Impl.Repository.User.Postgres (repository) where 2 | 3 | import Control.Monad.IO.Class (liftIO) 4 | import Control.Monad.Trans.Except (ExceptT (ExceptT), throwE, withExceptT) 5 | import Data.ByteString (isInfixOf) 6 | import Data.Text (Text) 7 | import Data.UUID.V4 (nextRandom) 8 | import Hasql.Session (CommandError (ResultError), QueryError (QueryError), ResultError (ServerError), Session) 9 | import Impl.Repository.User.Error (UserRepositoryError (..)) 10 | import Infrastructure.Database qualified as DB 11 | import Infrastructure.Persistence.Queries qualified as Query 12 | import Infrastructure.Persistence.Schema (litUser, userId) 13 | import Infrastructure.Persistence.Serializer (serializeUser, unserializeUser) 14 | import Tagger.EncryptedPassword (EncryptedPassword) 15 | import Tagger.Id (Id (Id)) 16 | import Tagger.Repository.User (UserRepository (..)) 17 | import Tagger.User (User (User)) 18 | 19 | -- | 20 | -- A 'UserRepository' based on PostgreSQL 21 | repository :: DB.Handle -> UserRepository (ExceptT UserRepositoryError IO) 22 | repository handle = 23 | UserRepository 24 | { findByName = postgresGetUserByName handle, 25 | add = postgresAddUser handle 26 | } 27 | 28 | postgresGetUserByName :: DB.Handle -> Text -> ExceptT UserRepositoryError IO (Id User, User) 29 | postgresGetUserByName handle name = do 30 | eitherUser <- runRepositoryQuery handle (Query.selectUserByName name) 31 | case eitherUser of 32 | Right usr -> pure (userId usr, unserializeUser usr) 33 | Left e -> throwE $ UnexpectedNumberOfRows e 34 | 35 | postgresAddUser :: DB.Handle -> Text -> EncryptedPassword -> ExceptT UserRepositoryError IO (Id User) 36 | postgresAddUser handle name password = do 37 | -- Generate the UUID for the user 38 | userId' <- liftIO nextRandom 39 | let query = Query.addUser . litUser $ serializeUser (Id userId') (User name password) 40 | 41 | -- Actually add the user to the database, differentiating the `UserRepositoryError` cases 42 | runRepositoryQuery handle query 43 | pure $ Id userId' 44 | 45 | -- | Run a query transforming a Hasql.QueryError into a UserRepositoryError as appropriate to the 46 | -- domain. 47 | runRepositoryQuery :: DB.Handle -> Session a -> ExceptT UserRepositoryError IO a 48 | runRepositoryQuery handle = withExceptT liftRepositoryError . ExceptT . DB.runQuery handle 49 | 50 | liftRepositoryError :: QueryError -> UserRepositoryError 51 | liftRepositoryError queryError@(QueryError _ _ (ResultError (ServerError "23505" message _ _ _))) 52 | | "users_name_key" `isInfixOf` message = DuplicateUserName queryError 53 | liftRepositoryError queryError = OtherError queryError 54 | -------------------------------------------------------------------------------- /src/Infrastructure/Authentication/PasswordManager.hs: -------------------------------------------------------------------------------- 1 | module Infrastructure.Authentication.PasswordManager where 2 | 3 | import Control.Category ((>>>)) 4 | import Control.Monad.Trans.Except (ExceptT (ExceptT)) 5 | import Crypto.JWT (Error) 6 | import Data.Bifunctor (bimap) 7 | import Infrastructure.Authentication.Token (Token (Token)) 8 | import Servant.Auth.Server (JWTSettings, makeJWT) 9 | import Tagger.Authentication.Credentials (Credentials, Password (asBytestring)) 10 | import Tagger.Authentication.Credentials qualified as Credentials (password) 11 | import Tagger.EncryptedPassword (EncryptedPassword, encryptPassword) 12 | import Tagger.EncryptedPassword qualified as Encrypted (validatePassword) 13 | import Tagger.Id (Id) 14 | import Tagger.User (User (password)) 15 | 16 | -- | 17 | -- A 'PasswordManager' is the service dedicated at dealing with password and authentication tokens 18 | -- It is indexed by a context 'm' which wraps the results. 19 | data PasswordManager m = PasswordManager 20 | { -- | given some 'Credentials', tries to encrypt the password 21 | generatePassword :: Credentials -> m EncryptedPassword, 22 | -- | given a 'User' 'Id', tries to generate an authentication 'Token' 23 | generateToken :: Id User -> m Token, 24 | -- | given a 'User' and a non excrypted 'Password', checks whether the password corresponds to the user's one 25 | validatePassword :: User -> Password -> Bool 26 | } 27 | 28 | -- | 29 | -- Given a natural transformation between a context 'm' and a context 'n', it allows to change the context where 'PasswordManager' is operating 30 | hoist :: (forall a. m a -> n a) -> PasswordManager m -> PasswordManager n 31 | hoist f PasswordManager {generatePassword, generateToken, validatePassword} = 32 | PasswordManager (f . generatePassword) (f . generateToken) validatePassword 33 | 34 | -- | 35 | -- How the 'PasswordManager' operations can fail 36 | data PasswordManagerError 37 | = -- | there was an error while hashing the password 38 | FailedHashing 39 | | -- | there was an error while generating the authentication token 40 | FailedJWTCreation Error 41 | deriving stock (Show) 42 | 43 | -- | 44 | -- A 'PasswordManager' implementation based on the 'bcrypt' algorithm 45 | bcryptPasswordManager :: JWTSettings -> PasswordManager (ExceptT PasswordManagerError IO) 46 | bcryptPasswordManager jwtSettings = 47 | PasswordManager 48 | { generatePassword = bcryptGeneratePassword, 49 | generateToken = bcryptGenerateToken jwtSettings, 50 | validatePassword = bcryptValidatePassword 51 | } 52 | 53 | bcryptGeneratePassword :: Credentials -> ExceptT PasswordManagerError IO EncryptedPassword 54 | bcryptGeneratePassword = 55 | -- extract the password from the Credentials 56 | Credentials.password 57 | -- convert it to bytestring 58 | >>> asBytestring 59 | -- try to encrypt it 60 | >>> encryptPassword 61 | -- wrap the error message to get a PasswordManagerError 62 | >>> fmap (maybe (Left FailedHashing) Right) 63 | -- wrap everything in ExceptT 64 | >>> ExceptT 65 | 66 | bcryptGenerateToken :: JWTSettings -> Id User -> ExceptT PasswordManagerError IO Token 67 | bcryptGenerateToken jwtSettings userId = ExceptT $ do 68 | -- try to generate the token containing the userId 69 | -- the Nothing means that the token does not expire 70 | token <- makeJWT userId jwtSettings Nothing 71 | -- wrap the error to get a PasswordErrorManager and the token to get a Token 72 | pure $ bimap FailedJWTCreation Token token 73 | 74 | bcryptValidatePassword :: User -> Password -> Bool 75 | bcryptValidatePassword user password' = Encrypted.validatePassword (password user) (asBytestring password') 76 | -------------------------------------------------------------------------------- /src/Infrastructure/Authentication/Token.hs: -------------------------------------------------------------------------------- 1 | module Infrastructure.Authentication.Token where 2 | 3 | import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), Value (String), withText) 4 | -- bytestring 5 | import Data.ByteString.Lazy (ByteString, fromStrict, toStrict) 6 | import Data.Data (Proxy (Proxy)) 7 | -- openapi3 8 | import Data.OpenApi (ToSchema (declareNamedSchema)) 9 | -- text 10 | import Data.Text (Text) 11 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) 12 | 13 | -- | 14 | -- An authentication 'Token' 15 | newtype Token = Token ByteString 16 | deriving newtype (Show) 17 | 18 | instance FromJSON Token where 19 | parseJSON = withText "Token" (pure . Token . fromStrict . encodeUtf8) 20 | 21 | instance ToJSON Token where 22 | toJSON (Token bs) = String . decodeUtf8 $ toStrict bs 23 | 24 | instance ToSchema Token where 25 | declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Text) 26 | -------------------------------------------------------------------------------- /src/Infrastructure/Database.hs: -------------------------------------------------------------------------------- 1 | module Infrastructure.Database 2 | ( Config (..), 3 | Handle, 4 | withHandle, 5 | runQuery, 6 | ) 7 | where 8 | 9 | import API.Config qualified as AppConfig 10 | import Control.Exception (bracket) 11 | import Data.ByteString.Char8 (ByteString, unpack) 12 | import Data.Maybe (fromMaybe) 13 | import Hasql.Connection (Connection, acquire, release) 14 | import Hasql.Session (QueryError, Session, run) 15 | 16 | newtype Config = Config 17 | { connectionString :: ByteString 18 | } 19 | 20 | newtype Handle = Handle 21 | { dbConnection :: Connection 22 | } 23 | 24 | new :: Config -> IO Handle 25 | new config = do 26 | eConn <- acquire . connectionString $ config 27 | either 28 | (fail . unpack . fromMaybe "unable to connect to the database") 29 | (pure . Handle) 30 | eConn 31 | 32 | parseConfig :: AppConfig.Config -> Config 33 | parseConfig = 34 | Config . (AppConfig.connectionString . AppConfig.database) 35 | 36 | close :: Handle -> IO () 37 | close = release . dbConnection 38 | 39 | withHandle :: AppConfig.Config -> (Handle -> IO a) -> IO a 40 | withHandle config f = do 41 | bracket 42 | (new . parseConfig $ config) 43 | close 44 | f 45 | 46 | runQuery :: Handle -> Session a -> IO (Either QueryError a) 47 | runQuery handle query = 48 | run query (dbConnection handle) 49 | -------------------------------------------------------------------------------- /src/Infrastructure/Logging/Logger.hs: -------------------------------------------------------------------------------- 1 | module Infrastructure.Logging.Logger 2 | ( Handle, 3 | withHandle, 4 | withContext, 5 | logError, 6 | logInfo, 7 | logWarning, 8 | logDebug, 9 | ) 10 | where 11 | 12 | import Colog.Core (Severity (..), logStringStderr, logStringStdout, (<&)) 13 | import Control.Exception (bracket) 14 | import Control.Monad (when) 15 | import Control.Monad.IO.Class (MonadIO) 16 | import Data.Text (Text) 17 | import Infrastructure.SystemTime (UTCTime) 18 | import Infrastructure.SystemTime qualified as SystemTime 19 | import Prelude hiding (log) 20 | 21 | newtype Config = Config 22 | { logLevel :: Severity 23 | } 24 | 25 | data Handle = Handle 26 | { systemTimeHandle :: SystemTime.Handle, 27 | localContext :: Maybe Context, 28 | minLevel :: Severity 29 | } 30 | 31 | type Context = Text 32 | 33 | -- | 34 | -- Uses dependencies to yield a handle 35 | withHandle :: SystemTime.Handle -> (Handle -> IO a) -> IO a 36 | withHandle timeHandle f = do 37 | bracket 38 | (new parseConfig timeHandle) 39 | close 40 | f 41 | 42 | -- | 43 | -- Returns new handle that logs within a specific context. 44 | withContext :: Context -> Handle -> Handle 45 | withContext context handle = handle {localContext = Just context} 46 | 47 | -- | 48 | -- Logs message with severity set to Error 49 | logError :: (MonadIO m) => Handle -> String -> m () 50 | logError = log Error 51 | 52 | -- | 53 | -- Logs message with severity set to Info 54 | logInfo :: (MonadIO m) => Handle -> String -> m () 55 | logInfo = log Info 56 | 57 | -- | 58 | -- Logs message with severity set to Warning 59 | logWarning :: (MonadIO m) => Handle -> String -> m () 60 | logWarning = log Warning 61 | 62 | -- | 63 | -- Logs message with severity set to Debug 64 | logDebug :: (MonadIO m) => Handle -> String -> m () 65 | logDebug = log Debug 66 | 67 | -- | 68 | -- Logs timestamped message with added severity and context 69 | -- information to appropriate file descriptor if severity meets 70 | -- minimum configured level 71 | log :: (MonadIO m) => Severity -> Handle -> String -> m () 72 | log level handle msg = do 73 | currentTime <- SystemTime.currentTime $ systemTimeHandle handle 74 | let formattedLine = format currentTime level (localContext handle) msg 75 | when (level >= minLevel handle) (logAction <& formattedLine) 76 | where 77 | logAction = 78 | case level of 79 | Error -> 80 | logStringStderr 81 | _ -> 82 | logStringStdout 83 | 84 | -- | 85 | -- Creates new handle 86 | new :: Config -> SystemTime.Handle -> IO Handle 87 | new config timeHandle = do 88 | pure $ 89 | Handle 90 | { systemTimeHandle = timeHandle, 91 | localContext = Nothing, 92 | minLevel = logLevel config 93 | } 94 | 95 | -- | 96 | -- Cleanup function 97 | close :: Handle -> IO () 98 | close = const $ pure () 99 | 100 | -- | 101 | -- Create Logger config 102 | parseConfig :: Config 103 | parseConfig = Config Info 104 | 105 | newtype Unquoted = Unquoted String 106 | 107 | instance Show Unquoted where 108 | show (Unquoted str) = str 109 | 110 | -- | 111 | -- Formats in following format: 112 | -- [Severity] [2022-06-13 14:54:39.043078872 UTC] [Context] Log message 113 | -- or (without context): 114 | -- [Severity] [2022-06-13 14:54:39.043078872 UTC] Log message 115 | format :: UTCTime -> Severity -> Maybe Context -> String -> String 116 | format time severity ctx msg = 117 | withBrackets severity <> withBrackets time <> maybe "" withBrackets ctx <> msg 118 | where 119 | withBrackets s = 120 | "[" <> show s <> "] " 121 | -------------------------------------------------------------------------------- /src/Infrastructure/Persistence/Queries.hs: -------------------------------------------------------------------------------- 1 | module Infrastructure.Persistence.Queries where 2 | 3 | import Data.List qualified as List (filter) 4 | import Data.Text (Text) 5 | import Hasql.Session (Session, statement) 6 | import Hasql.Statement (Statement) 7 | import Hasql.Transaction qualified as Transaction (statement) 8 | import Hasql.Transaction.Sessions (IsolationLevel (Serializable), Mode (Write), transaction) 9 | import Infrastructure.Persistence.Schema (Content (..), ContentsTags (..), Tag (..), User (userName), contentSchema, contentsTagsSchema, litContent, litTag, tagSchema, userId, userSchema) 10 | import Rel8 (Expr, Insert (..), Name, OnConflict (..), Query, Rel8able, Result, TableSchema, each, filter, in_, insert, lit, many, select, values, where_, (==.)) 11 | import Tagger.Id (Id) 12 | import Tagger.User qualified as Domain (User) 13 | import Prelude hiding (filter) 14 | 15 | -- SELECT CONTENTS 16 | 17 | -- | 18 | -- Selects the 'ContentsTags' for a given 'Content' 19 | contentsTagsForContent :: Content Expr -> Query (ContentsTags Expr) 20 | contentsTagsForContent content = 21 | each contentsTagsSchema 22 | >>= filter 23 | ( \contentTag' -> 24 | ctContentId contentTag' ==. contentId content 25 | ) 26 | 27 | -- | 28 | -- Selects the 'Tags' associated with a given 'Content' 29 | tagsForContent :: Content Expr -> Query (Tag Expr) 30 | tagsForContent content = do 31 | tag <- each tagSchema 32 | contentTag' <- contentsTagsForContent content 33 | where_ $ tagId tag ==. ctTagId contentTag' 34 | return tag 35 | 36 | -- | 37 | -- Selects the 'User' who ownes a 'Content' 38 | userForContent :: Content Expr -> Query (User Expr) 39 | userForContent content = 40 | each userSchema 41 | >>= filter 42 | ( \user -> 43 | userId user ==. contentUserId content 44 | ) 45 | 46 | -- | 47 | -- Given a 'Domain.User' 'Id', retrieves all the contents for that specific user 48 | selectUserContents :: Id Domain.User -> Session [(Content Result, [Tag Result], User Result)] 49 | selectUserContents userId' = statement () . select $ do 50 | -- Select all content for the given user 51 | content <- 52 | each contentSchema 53 | >>= filter 54 | ( \content -> 55 | contentUserId content ==. lit userId' 56 | ) 57 | -- Select tags for each content 58 | tags <- many $ tagsForContent content 59 | -- Select user for each content 60 | user <- userForContent content 61 | return (content, tags, user) 62 | 63 | -- SELECT TAGS 64 | 65 | -- | 66 | -- Selects all tags present in the database among the requested ones 67 | selectTags :: [Tag Result] -> Statement () [Tag Result] 68 | selectTags tagNames = select $ each tagSchema >>= filter ((`in_` (tagName . litTag <$> tagNames)) . tagName) 69 | 70 | -- ADD CONTENT 71 | 72 | -- | 73 | -- Adds a number of rows to the specified 'TableSchema' 74 | add :: (Rel8able f) => TableSchema (f Name) -> [f Expr] -> Statement () () 75 | add schema rows' = 76 | insert $ 77 | Insert 78 | { into = schema, 79 | rows = values rows', 80 | onConflict = Abort, 81 | returning = pure () 82 | } 83 | 84 | -- | 85 | -- Creates a 'ContentTag' given a 'Content' and a 'Tag' 86 | contentTag :: Content f -> Tag f -> ContentsTags f 87 | contentTag content tag = 88 | ContentsTags 89 | { ctContentId = contentId content, 90 | ctTagId = tagId tag 91 | } 92 | 93 | -- | 94 | -- Removes the 'alreadyPresentTags' from 'allTags' 95 | removeAlreadyPresentTags :: [Tag Result] -> [Tag Result] -> [Tag Result] 96 | removeAlreadyPresentTags allTags alreadyPresentTags = List.filter (\tag -> tagName tag `notElem` (tagName <$> alreadyPresentTags)) allTags 97 | 98 | -- | 99 | -- Given a 'Content' and a list of 'Tag's, it inserts the new content into the database associating to it the provided tags. 100 | -- To avoid 'Tag' repetitions, it goes through the following steps: 101 | -- 102 | -- * selects 'Tag's from the database 103 | -- * replaces the generated 'UUID's with the one coming from the database 104 | -- * inserts the new 'Tag's 105 | -- * inserts the 'Content' 106 | -- * inserts the 'ContentsTags' to link the 'Content' with its 'Tags' 107 | addContentWithTags :: Content Result -> [Tag Result] -> Session () 108 | addContentWithTags content tags = transaction Serializable Write $ do 109 | alreadyPresentTags <- Transaction.statement () (selectTags tags) 110 | let newTags = litTag <$> removeAlreadyPresentTags tags alreadyPresentTags 111 | Transaction.statement () $ add tagSchema newTags 112 | Transaction.statement () $ add contentSchema [litContent content] 113 | Transaction.statement () $ add contentsTagsSchema (contentTag (litContent content) <$> (litTag <$> alreadyPresentTags) <> newTags) 114 | 115 | -- SELECT USER BY USERNAME 116 | 117 | -- | 118 | -- Describes the possible error cases for queries that expect exactly one row as a result. 119 | data WrongNumberOfResults 120 | = NoResults 121 | | MoreThanOneResult 122 | deriving (Show) 123 | 124 | -- | 125 | -- Given a list of results, succeed if there is only one in the list, otherwise fail with the appropriate error message 126 | justOne :: [a Result] -> Either WrongNumberOfResults (a Result) 127 | justOne = \case 128 | [] -> Left NoResults 129 | [a] -> Right a 130 | _ -> Left MoreThanOneResult 131 | 132 | -- | 133 | -- Retrieve from the database a user with the provided name. 134 | -- If in the database we find none or more the one, it returns the appropriate error message 135 | selectUserByName :: Text -> Session (Either WrongNumberOfResults (User Result)) 136 | selectUserByName name = statement () query 137 | where 138 | query = fmap justOne . select $ do 139 | users <- each userSchema 140 | filter (\user -> userName user ==. lit name) users 141 | 142 | -- ADD USER 143 | 144 | -- | 145 | -- Add a new 'User' in the database 146 | addUser :: User Expr -> Session () 147 | addUser = statement () . add userSchema . pure 148 | -------------------------------------------------------------------------------- /src/Infrastructure/Persistence/Schema.hs: -------------------------------------------------------------------------------- 1 | module Infrastructure.Persistence.Schema where 2 | 3 | import Data.Text (Text) 4 | import GHC.Generics (Generic) 5 | import Rel8 (Column, Expr, Name, Rel8able, Result, TableSchema (..), lit) 6 | import Tagger.Content qualified as Domain (Content) 7 | import Tagger.EncryptedPassword (EncryptedPassword) 8 | import Tagger.Id (Id) 9 | import Tagger.Tag qualified as Domain (Tag) 10 | import Tagger.User qualified as Domain (User) 11 | 12 | -- TAG 13 | 14 | -- | 15 | -- The database representation of a 'Tag' 16 | data Tag f = Tag 17 | { tagId :: Column f (Id Domain.Tag), 18 | tagName :: Column f Text 19 | } 20 | deriving stock (Generic) 21 | deriving anyclass (Rel8able) 22 | 23 | -- | 24 | -- A description of the schema of the 'Tag' table 25 | tagSchema :: TableSchema (Tag Name) 26 | tagSchema = 27 | TableSchema 28 | { name = "tags", 29 | schema = Nothing, 30 | columns = 31 | Tag 32 | { tagId = "id", 33 | tagName = "name" 34 | } 35 | } 36 | 37 | -- | 38 | -- Allows to lift a 'Tag' with no context into the 'Expr' context 39 | litTag :: Tag Result -> Tag Expr 40 | litTag (Tag id' name') = Tag (lit id') (lit name') 41 | 42 | -- CONTENT 43 | 44 | -- | 45 | -- The database representation of a 'Content' 46 | data Content f = Content 47 | { contentId :: Column f (Id (Domain.Content Domain.Tag)), 48 | contentContent :: Column f Text, 49 | contentUserId :: Column f (Id Domain.User) 50 | } 51 | deriving stock (Generic) 52 | deriving anyclass (Rel8able) 53 | 54 | -- | 55 | -- A description of the schema of the 'Content' table 56 | contentSchema :: TableSchema (Content Name) 57 | contentSchema = 58 | TableSchema 59 | { name = "contents", 60 | schema = Nothing, 61 | columns = 62 | Content 63 | { contentId = "id", 64 | contentContent = "content", 65 | contentUserId = "user_id" 66 | } 67 | } 68 | 69 | -- | 70 | -- Allows to lift a 'Content' with no context into the 'Expr' context 71 | litContent :: Content Result -> Content Expr 72 | litContent (Content id' content' userId') = Content (lit id') (lit content') (lit userId') 73 | 74 | -- CONTENTS_TAGS 75 | 76 | -- | 77 | -- The database representation of a connection between a 'Content' and a 'Tag' 78 | data ContentsTags f = ContentsTags 79 | { ctContentId :: Column f (Id (Domain.Content Domain.Tag)), 80 | ctTagId :: Column f (Id Domain.Tag) 81 | } 82 | deriving stock (Generic) 83 | deriving anyclass (Rel8able) 84 | 85 | -- | 86 | -- A description of the schema of the 'ContentsTags' table 87 | contentsTagsSchema :: TableSchema (ContentsTags Name) 88 | contentsTagsSchema = 89 | TableSchema 90 | { name = "contents_tags", 91 | schema = Nothing, 92 | columns = 93 | ContentsTags 94 | { ctContentId = "content_id", 95 | ctTagId = "tag_id" 96 | } 97 | } 98 | 99 | -- USERS 100 | 101 | -- | 102 | -- The database representation of a 'User' 103 | data User f = User 104 | { userId :: Column f (Id Domain.User), 105 | userName :: Column f Text, 106 | userPassword :: Column f EncryptedPassword 107 | } 108 | deriving stock (Generic) 109 | deriving anyclass (Rel8able) 110 | 111 | -- | 112 | -- A description of the schema of the 'User' table 113 | userSchema :: TableSchema (User Name) 114 | userSchema = 115 | TableSchema 116 | { name = "users", 117 | schema = Nothing, 118 | columns = 119 | User 120 | { userId = "id", 121 | userName = "name", 122 | userPassword = "password" 123 | } 124 | } 125 | 126 | -- | 127 | -- Allows to lift a 'User' with no context into the 'Expr' context 128 | litUser :: User Result -> User Expr 129 | litUser (User id' name' password) = User (lit id') (lit name') (lit password) 130 | -------------------------------------------------------------------------------- /src/Infrastructure/Persistence/Serializer.hs: -------------------------------------------------------------------------------- 1 | module Infrastructure.Persistence.Serializer where 2 | 3 | import Infrastructure.Persistence.Schema (contentContent, contentId, contentUserId, tagId, tagName, userId, userName, userPassword) 4 | import Infrastructure.Persistence.Schema qualified as DB (Content (Content), Tag (Tag), User (User)) 5 | import Rel8 (Result) 6 | import Tagger.Content (Content (..), createContent) 7 | import Tagger.Id (Id) 8 | import Tagger.Owned (Owned (Owned)) 9 | import Tagger.Owned qualified as Owned (content, userId) 10 | import Tagger.Tag (Tag (Tag)) 11 | import Tagger.Tag qualified as Tag (name) 12 | import Tagger.User (User (User)) 13 | import Tagger.User qualified as User (name, password) 14 | 15 | -- CONTENT 16 | 17 | -- | 18 | -- Transform from a domain representation of a 'Content' to its underlying database representation 19 | serializeContent :: Id (Content Tag) -> Id User -> Content (Id Tag, Tag) -> (DB.Content Result, [DB.Tag Result]) 20 | serializeContent contentId' userId' content = (dbContent, dbTags) 21 | where 22 | dbContent = 23 | DB.Content 24 | { contentId = contentId', 25 | contentContent = message content, 26 | contentUserId = userId' 27 | } 28 | dbTags = uncurry serializeTag <$> tags content 29 | 30 | -- | 31 | -- Transform from the database representation of a 'Content' to its domain representation 32 | unserializeContent :: DB.Content Result -> [DB.Tag Result] -> DB.User Result -> Owned (Content Tag) 33 | unserializeContent content tags' user = 34 | Owned 35 | { Owned.content = 36 | createContent 37 | (contentContent content) 38 | (unserializeTag <$> tags'), 39 | Owned.userId = userId user 40 | } 41 | 42 | -- TAG 43 | 44 | -- | 45 | -- Transform from a domain representation of a 'Tag' to its underlying database representation 46 | serializeTag :: Id Tag -> Tag -> DB.Tag Result 47 | serializeTag uuid tag = 48 | DB.Tag 49 | { tagId = uuid, 50 | tagName = Tag.name tag 51 | } 52 | 53 | -- | 54 | -- Transform from the database representation of a 'Tag' to its domain representation 55 | unserializeTag :: DB.Tag Result -> Tag 56 | unserializeTag tag = Tag (tagName tag) 57 | 58 | -- USER 59 | 60 | -- | 61 | -- Transform from a domain representation of a 'User' to its underlying database representation 62 | serializeUser :: Id User -> User -> DB.User Result 63 | serializeUser uuid user = 64 | DB.User 65 | { userId = uuid, 66 | userName = User.name user, 67 | userPassword = User.password user 68 | } 69 | 70 | -- | 71 | -- Transform from the database representation of a 'User' to its domain representation 72 | unserializeUser :: DB.User Result -> User 73 | unserializeUser user = User (userName user) (userPassword user) 74 | -------------------------------------------------------------------------------- /src/Infrastructure/SystemTime.hs: -------------------------------------------------------------------------------- 1 | module Infrastructure.SystemTime 2 | ( Handle, 3 | withHandle, 4 | currentTime, 5 | UTCTime, 6 | ) 7 | where 8 | 9 | import Control.Exception (bracket) 10 | import Control.Monad.IO.Class (MonadIO (liftIO)) 11 | import Data.Time.Clock (UTCTime, getCurrentTime) 12 | 13 | data Handle = Handle 14 | 15 | -- | 16 | -- Yields a handle 17 | withHandle :: (Handle -> IO a) -> IO a 18 | withHandle = bracket new close 19 | 20 | -- | 21 | -- Returns current time 22 | currentTime :: (MonadIO m) => Handle -> m UTCTime 23 | currentTime = const $ liftIO getCurrentTime 24 | 25 | -- | 26 | -- Creates new handle 27 | new :: (MonadIO m) => m Handle 28 | new = pure Handle 29 | 30 | -- | 31 | -- Cleanup function 32 | close :: (MonadIO m) => Handle -> m () 33 | close = const $ pure () 34 | -------------------------------------------------------------------------------- /src/Middleware.hs: -------------------------------------------------------------------------------- 1 | module Middleware (apply) where 2 | 3 | import Network.Wai qualified as Wai (Application, Middleware) 4 | import Network.Wai.Middleware.Cors (cors, corsRequestHeaders, simpleCorsResourcePolicy) 5 | import Network.Wai.Middleware.RequestLogger (logStdoutDev) 6 | 7 | apply :: Wai.Application -> Wai.Application 8 | apply = 9 | corsMiddleware . logStdoutDev 10 | 11 | corsMiddleware :: Wai.Middleware 12 | corsMiddleware = 13 | let headers = ["Authorization", "Content-Type"] 14 | in cors (const . Just $ simpleCorsResourcePolicy {corsRequestHeaders = headers}) 15 | -------------------------------------------------------------------------------- /src/Tagger/Authentication/Authenticator.hs: -------------------------------------------------------------------------------- 1 | module Tagger.Authentication.Authenticator where 2 | 3 | import Tagger.Authentication.Credentials (Credentials (..)) 4 | import Tagger.Id (Id) 5 | import Tagger.User (User) 6 | 7 | -- | 8 | -- 'AuthenticateUser' is a service which exposes the ability to authenticate a 'User' providing her 'Credentials'. 9 | -- It is indexed by a context 'm' which wraps the results. 10 | newtype Authenticator m = Authenticator {authUser :: Credentials -> m (Id User)} 11 | 12 | -- | 13 | -- Given a natural transformation between a context 'm' and a context 'n', it allows to change the context where 'AuthenticateUser' is operating 14 | hoist :: (forall a. m a -> n a) -> Authenticator m -> Authenticator n 15 | hoist f (Authenticator auth) = Authenticator $ f . auth 16 | -------------------------------------------------------------------------------- /src/Tagger/Authentication/Credentials.hs: -------------------------------------------------------------------------------- 1 | module Tagger.Authentication.Credentials where 2 | 3 | import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON)) 4 | -- bytestring 5 | import Data.ByteString (ByteString) 6 | -- openapi3 7 | import Data.OpenApi (ToSchema (declareNamedSchema)) 8 | import Data.Proxy (Proxy (Proxy)) 9 | -- text 10 | import Data.Text (Text) 11 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) 12 | import GHC.Generics (Generic) 13 | 14 | -- | 15 | -- A newtype wrapper over 'ByteString' to represent a non encrypted password 16 | newtype Password = Password {asBytestring :: ByteString} 17 | 18 | instance FromJSON Password where 19 | parseJSON json = Password . encodeUtf8 <$> parseJSON json 20 | 21 | instance ToJSON Password where 22 | toJSON (Password s) = toJSON $ decodeUtf8 s 23 | 24 | instance ToSchema Password where 25 | declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Text) 26 | 27 | data Credentials = Credentials 28 | { username :: Text, 29 | password :: Password 30 | } 31 | deriving stock (Generic) 32 | deriving anyclass (FromJSON, ToJSON, ToSchema) 33 | -------------------------------------------------------------------------------- /src/Tagger/Content.hs: -------------------------------------------------------------------------------- 1 | module Tagger.Content (Content (message, tags), createContent, hasAllTags) where 2 | 3 | import Data.Aeson (FromJSON, ToJSON) 4 | import Data.List (nub) 5 | import Data.OpenApi (ToSchema) 6 | import Data.Text (Text) 7 | import GHC.Generics (Generic) 8 | 9 | -- | 10 | -- A 'Content' is just a text indexed by a list of 'tag's 11 | data Content tag = Content 12 | { message :: Text, 13 | tags :: [tag] 14 | } 15 | deriving stock (Eq, Show, Functor, Generic) 16 | 17 | createContent :: (Eq tag) => Text -> [tag] -> Content tag 18 | createContent message tags = Content message (nub tags) 19 | 20 | instance Foldable Content where 21 | foldMap f = foldMap f . tags 22 | 23 | instance Traversable Content where 24 | traverse f Content {message, tags} = Content message <$> traverse f tags 25 | 26 | instance (ToSchema tag) => ToSchema (Content tag) 27 | 28 | instance (FromJSON tag) => FromJSON (Content tag) 29 | 30 | instance (ToJSON tag) => ToJSON (Content tag) 31 | 32 | -- | 33 | -- checks whether a 'Content' is indexed by all the provided 'tag's 34 | hasAllTags :: (Eq tag) => [tag] -> Content tag -> Bool 35 | hasAllTags tags' content = all (\tag -> tag `elem` tags content) tags' 36 | -------------------------------------------------------------------------------- /src/Tagger/EncryptedPassword.hs: -------------------------------------------------------------------------------- 1 | module Tagger.EncryptedPassword (EncryptedPassword, asBytestring, encryptPassword, validatePassword) where 2 | 3 | import Crypto.BCrypt (fastBcryptHashingPolicy, hashPasswordUsingPolicy) 4 | import Crypto.BCrypt qualified as BCrypt (validatePassword) 5 | import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON)) 6 | import Data.ByteString (ByteString) 7 | import Data.Data (Proxy (Proxy)) 8 | import Data.OpenApi (ToSchema (declareNamedSchema)) 9 | import Data.Text (Text) 10 | import Data.Text.Encoding (decodeUtf8, encodeUtf8) 11 | import GHC.Generics (Generic) 12 | import Rel8 (DBEq, DBType) 13 | 14 | -- | 15 | -- An 'EncryptedPassword' is a newtype wrapping a 'Bytestring'. 16 | -- We do not export the constructor to enforce that an 'EncryptedPassword' is built using 'encryptPassword' 17 | newtype EncryptedPassword = EncryptedPassword {asBytestring :: ByteString} 18 | deriving stock (Eq, Show, Read, Generic) 19 | deriving newtype (DBEq, DBType) 20 | 21 | instance FromJSON EncryptedPassword where 22 | parseJSON json = EncryptedPassword . encodeUtf8 <$> parseJSON json 23 | 24 | instance ToJSON EncryptedPassword where 25 | toJSON (EncryptedPassword s) = toJSON $ decodeUtf8 s 26 | 27 | instance ToSchema EncryptedPassword where 28 | declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy Text) 29 | 30 | -- | 31 | -- encrypt a 'ByteString' into an 'EncryptedPassword' using bcrypt with 'fastBcryptHashingPolicy' 32 | encryptPassword :: ByteString -> IO (Maybe EncryptedPassword) 33 | encryptPassword password = fmap EncryptedPassword <$> hashPasswordUsingPolicy fastBcryptHashingPolicy password 34 | 35 | -- | 36 | -- Given an 'EncryptedPassword' and a 'ByteString' password, it checks whether the password is valid 37 | validatePassword :: EncryptedPassword -> ByteString -> Bool 38 | validatePassword (EncryptedPassword password) = BCrypt.validatePassword password 39 | -------------------------------------------------------------------------------- /src/Tagger/Id.hs: -------------------------------------------------------------------------------- 1 | module Tagger.Id where 2 | 3 | import Data.Aeson (FromJSON, ToJSON) 4 | import Data.OpenApi (ToSchema) 5 | import Data.UUID (UUID) 6 | import Rel8 (DBEq, DBType) 7 | import Servant.Auth.JWT (FromJWT, ToJWT) 8 | 9 | -- | 10 | -- An 'Id' is a newtype around a 'UUID' with a phantom type 'a' to keep track what the identifier is actually referring to 11 | newtype Id a = Id {getUUID :: UUID} 12 | deriving stock (Eq, Ord, Show) 13 | deriving anyclass (FromJWT, ToJWT) 14 | deriving newtype (DBEq, DBType, FromJSON, ToJSON, ToSchema) 15 | -------------------------------------------------------------------------------- /src/Tagger/JSONWebKey.hs: -------------------------------------------------------------------------------- 1 | module Tagger.JSONWebKey (setup, JWK) where 2 | 3 | import CLIOptions (CLIOptions (jwkPath)) 4 | import Control.Exception (catch) 5 | import Crypto.JOSE.JWK (JWK) 6 | import Data.ByteString.Char8 (writeFile) 7 | import Servant.Auth.Server (fromSecret, generateSecret, readKey) 8 | import Prelude hiding (writeFile) 9 | 10 | setup :: CLIOptions -> IO JWK 11 | setup config = do 12 | let path = jwkPath config 13 | -- try to retrieve the JWK from file 14 | catch (readKey path) $ \(_ :: IOError) -> do 15 | -- if the file does not exist or does not contain a valid key, we generate one 16 | key <- generateSecret 17 | -- and we store it 18 | writeFile path key 19 | pure $ fromSecret key 20 | -------------------------------------------------------------------------------- /src/Tagger/Owned.hs: -------------------------------------------------------------------------------- 1 | module Tagger.Owned where 2 | 3 | import Data.Aeson (FromJSON, ToJSON) 4 | import Data.OpenApi (ToSchema) 5 | import GHC.Generics (Generic) 6 | import Tagger.Id (Id) 7 | import Tagger.User (User) 8 | 9 | -- | 10 | -- 'Owned' is a data type used to associate a 'User' to a content via its 'Id' 11 | data Owned a = Owned 12 | { userId :: Id User, 13 | content :: a 14 | } 15 | deriving stock (Eq, Show, Generic) 16 | 17 | instance (FromJSON a) => FromJSON (Owned a) 18 | 19 | instance (ToJSON a) => ToJSON (Owned a) 20 | 21 | instance (ToSchema a) => ToSchema (Owned a) 22 | -------------------------------------------------------------------------------- /src/Tagger/Repository/Content.hs: -------------------------------------------------------------------------------- 1 | module Tagger.Repository.Content where 2 | 3 | import Tagger.Content (Content) 4 | import Tagger.Id (Id) 5 | import Tagger.Owned (Owned) 6 | import Tagger.Tag (Tag) 7 | import Tagger.User (User) 8 | 9 | -- | 10 | -- A 'ContentRepository' represents a collection of 'Content's. 11 | -- It is indexed by a context 'm' which wraps the results. 12 | data ContentRepository m = ContentRepository 13 | { -- | selects all the 'Content's 'Owned' by a 'User' with a given 'Id' and indexed by all the provided 'Tag's 14 | selectUserContentsByTags :: Id User -> [Tag] -> m [Owned (Content Tag)], 15 | -- | adds a 'Content' indexed by some 'Tag's for a 'User' identified by a given 'Id' 16 | addContentWithTags :: Id User -> Content Tag -> m (Id (Content Tag)) 17 | } 18 | 19 | -- | 20 | -- Given a natural transformation between a context 'm' and a context 'n', it allows to change the context where 'ContentRepository' is operating 21 | hoist :: (forall a. m a -> n a) -> ContentRepository m -> ContentRepository n 22 | hoist f ContentRepository {selectUserContentsByTags, addContentWithTags} = 23 | ContentRepository ((f .) . selectUserContentsByTags) ((f .) . addContentWithTags) 24 | -------------------------------------------------------------------------------- /src/Tagger/Repository/User.hs: -------------------------------------------------------------------------------- 1 | module Tagger.Repository.User (UserRepository (..), hoist) where 2 | 3 | import Data.Text (Text) 4 | import Tagger.EncryptedPassword (EncryptedPassword) 5 | import Tagger.Id (Id) 6 | import Tagger.User (User) 7 | 8 | -- | 9 | -- A 'UserRespository' represents a collection of 'User's. 10 | -- It is indexed by a context 'm' which wraps the results. 11 | data UserRepository m = UserRepository 12 | { -- | Searches the repository for 'User's with the provided name 13 | findByName :: Text -> m (Id User, User), 14 | -- | Adds a user with the provided name and password 15 | add :: Text -> EncryptedPassword -> m (Id User) 16 | } 17 | 18 | -- | 19 | -- Given a natural transformation between a context 'm' and a context 'n', it allows to change the context where 'UserRepository' is operating 20 | hoist :: (forall a. m a -> n a) -> UserRepository m -> UserRepository n 21 | hoist f UserRepository {findByName, add} = UserRepository (f . findByName) ((f .) . add) 22 | -------------------------------------------------------------------------------- /src/Tagger/Tag.hs: -------------------------------------------------------------------------------- 1 | module Tagger.Tag where 2 | 3 | import Data.Aeson (FromJSON, ToJSON) 4 | import Data.OpenApi (ToParamSchema, ToSchema) 5 | -- text 6 | import Data.Text (Text) 7 | import Servant (FromHttpApiData, ToHttpApiData) 8 | 9 | -- | 10 | -- A 'Tag' is a newtype wrapper around some 'Text', used to index a 'Tagger.Content.Content' 11 | newtype Tag = Tag {name :: Text} 12 | deriving stock (Eq, Show) 13 | deriving newtype (FromHttpApiData, ToHttpApiData, ToParamSchema, ToSchema, FromJSON, ToJSON) 14 | -------------------------------------------------------------------------------- /src/Tagger/User.hs: -------------------------------------------------------------------------------- 1 | module Tagger.User where 2 | 3 | import Data.Aeson (ToJSON (toJSON), object, (.=)) 4 | import Data.OpenApi (ToSchema) 5 | import Data.Text (Text) 6 | import GHC.Generics (Generic) 7 | import Tagger.EncryptedPassword (EncryptedPassword) 8 | 9 | -- | 10 | -- A 'User' contains a 'Text' and an 'EncryptedPassword' 11 | data User = User 12 | { name :: Text, 13 | password :: EncryptedPassword 14 | } 15 | deriving stock (Eq, Show, Read, Generic) 16 | 17 | -- | 18 | -- We need to be careful to hide the password (even if it is encrypted) when we expose an 'User' 19 | instance ToJSON User where 20 | toJSON User {name} = object ["name" .= name] 21 | 22 | instance ToSchema User 23 | --------------------------------------------------------------------------------