├── .github └── workflows │ └── doc.yml ├── .gitignore ├── FPauth-core.opam ├── FPauth-responses.opam ├── FPauth-strategies.opam ├── FPauth.opam ├── LICENSE.md ├── Makefile ├── README.md ├── docs └── code-example.svg ├── dune-project ├── src ├── FPauth.ml ├── FPauth.mli ├── core │ ├── FPauth_core.ml │ ├── FPauth_core.mli │ ├── auth_sign.ml │ ├── authenticator.ml │ ├── dune │ ├── router.ml │ ├── session_manager.ml │ ├── static.ml │ ├── static.mli │ └── variables.ml ├── dune ├── responses │ ├── FPauth_responses.ml │ ├── HTML.ml │ ├── JSON.ml │ ├── dune │ └── html_pages.eml.ml └── strategies │ ├── FPauth_strategies.ml │ ├── TOTP.ml │ ├── TOTP.mli │ ├── TOTP_pages.eml.ml │ ├── dune │ ├── password.ml │ └── password.mli └── test ├── core ├── authenticator.ml ├── dune ├── router.ml ├── session_manager.ml ├── setup.ml ├── static.ml └── unit.ml └── strategies ├── dune ├── password.ml ├── setup.ml ├── totp.ml └── unit.ml /.github/workflows/doc.yml: -------------------------------------------------------------------------------- 1 | name: Deploy API Documentation & Coveralls report 2 | 3 | on: 4 | push: 5 | branches: 6 | - deploy-doc 7 | 8 | jobs: 9 | deploy-doc: 10 | runs-on: ubuntu-latest 11 | steps: 12 | 13 | - name: Checkout code 14 | uses: actions/checkout@v2 15 | 16 | - name: Use OCaml 4.13.x 17 | uses: ocaml/setup-ocaml@v2 18 | with: 19 | ocaml-compiler: 4.13.x 20 | dune-cache: true 21 | opam-pin: false 22 | opam-depext: false 23 | 24 | - name: Pin packages 25 | run: | 26 | for f in *.opam; do 27 | opam pin add -yn "${f%.opam}" --dev-repo . 28 | done 29 | shell: bash 30 | 31 | - name: Install system dependencies 32 | run: | 33 | opam depext -y --with-doc --with-test $(ls -1 *.opam | sed -e 's/\.opam$//') 34 | shell: bash 35 | 36 | - name: Install OCaml dependencies 37 | run: opam install --deps-only -y --with-doc --with-test $(ls -1 *.opam | sed -e 's/\.opam$//') 38 | shell: bash 39 | 40 | - name: Deploy odoc to GitHub Pages 41 | uses: ocaml/setup-ocaml/deploy-doc@v2 42 | 43 | - name: Generate coverage report 44 | run: opam exec -- dune runtest --instrument-with bisect_ppx --force 45 | shell: bash 46 | 47 | - name: Send report to Coveralls 48 | run: opam exec -- bisect-ppx-report send-to Coveralls 49 | env: 50 | COVERALLS_REPO_TOKEN: ${{ secrets.GITHUB_TOKEN }} 51 | PULL_REQUEST_NUMBER: ${{ github.event.number }} 52 | shell: bash -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.code-workspace 2 | _build 3 | _esy 4 | .vscode 5 | 6 | # Dune 7 | _build/ 8 | .merlin 9 | *.install 10 | 11 | # opam 12 | _opam/ 13 | 14 | # Bisect_ppx 15 | _coverage/ 16 | 17 | _doc/ -------------------------------------------------------------------------------- /FPauth-core.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | 3 | name: "FPauth-core" 4 | version: "1.0.0" 5 | license: "MIT" 6 | 7 | synopsis: "Easy authentication system for Dream framework" 8 | 9 | homepage: "https://github.com/mikeGEINE/FPauth" 10 | bug-reports: "https://github.com/mikeGEINE/FPauth/issues" 11 | dev-repo: "git+https://github.com/mikeGEINE/FPauth.git" 12 | 13 | authors: ["Mikhail Geine " 14 | "Pavel Argentov "] 15 | maintainer: "Mikhail Geine " 16 | 17 | build: [ 18 | ["dune" "build" "-p" name "-j" jobs] 19 | ] 20 | 21 | run-test: [ 22 | ["dune" "runtest" "-p" name "-j" jobs] 23 | ] 24 | 25 | depends: [ 26 | "dream" {>="1.0.0~alpha3"} 27 | "ocaml" {>="4.12.0"} 28 | "dune" {>="2.7"} 29 | "lwt_ppx" {>= "2.0.3"} 30 | "base" 31 | 32 | #Testing, development 33 | "alcotest" {with-test} 34 | "bisect_ppx" {with-test & >= "2.5.0"} # --instrument-with. 35 | "odoc" {with-doc} 36 | ] 37 | conflicts: [ 38 | "base-nnp" 39 | "ocaml-option-nnpchecker" 40 | ] -------------------------------------------------------------------------------- /FPauth-responses.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | 3 | name: "FPauth-responses" 4 | version: "1.0.0" 5 | license: "MIT" 6 | 7 | synopsis: "Responses on basic events in FPauth-core authentication system" 8 | 9 | homepage: "https://github.com/mikeGEINE/FPauth" 10 | bug-reports: "https://github.com/mikeGEINE/FPauth/issues" 11 | dev-repo: "git+https://github.com/mikeGEINE/FPauth.git" 12 | 13 | authors: ["Mikhail Geine " 14 | "Pavel Argentov "] 15 | maintainer: "Mikhail Geine " 16 | 17 | build: [ 18 | ["dune" "build" "-p" name "-j" jobs] 19 | ] 20 | 21 | run-test: [ 22 | ["dune" "runtest" "-p" name "-j" jobs] 23 | ] 24 | 25 | depends: [ 26 | "dream" {>="1.0.0~alpha3"} 27 | "ocaml" {>="4.12.0"} 28 | "dune" {>="2.7"} 29 | "base" 30 | "FPauth-core" {= version} 31 | 32 | #Testing, development 33 | "alcotest" {with-test} 34 | "bisect_ppx" {with-test & >= "2.5.0"} # --instrument-with. 35 | "odoc" {with-doc} 36 | ] -------------------------------------------------------------------------------- /FPauth-strategies.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | 3 | name: "FPauth-strategies" 4 | version: "1.0.0" 5 | license: "MIT" 6 | 7 | synopsis: "Strategies to be used with FPauth-core authentication system" 8 | 9 | homepage: "https://github.com/mikeGEINE/FPauth" 10 | bug-reports: "https://github.com/mikeGEINE/FPauth/issues" 11 | dev-repo: "git+https://github.com/mikeGEINE/FPauth.git" 12 | 13 | authors: ["Mikhail Geine " 14 | "Pavel Argentov "] 15 | maintainer: "Mikhail Geine " 16 | 17 | build: [ 18 | ["dune" "build" "-p" name "-j" jobs] 19 | ] 20 | 21 | run-test: [ 22 | ["dune" "runtest" "-p" name "-j" jobs] 23 | ] 24 | 25 | depends: [ 26 | "dream" {>="1.0.0~alpha3"} 27 | "argon2" 28 | "twostep" 29 | "FPauth-core" {= version} 30 | "ocaml" {>="4.12.0"} 31 | "dune" {>="2.7"} 32 | "base" 33 | "conf-libargon2" 34 | 35 | #Testing, development 36 | "alcotest" {with-test} 37 | "bisect_ppx" {with-test & >= "2.5.0"} # --instrument-with. 38 | "odoc" {with-doc} 39 | ] 40 | -------------------------------------------------------------------------------- /FPauth.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | 3 | name: "FPauth" 4 | version: "1.0.0" 5 | license: "MIT" 6 | 7 | synopsis: "Easy authentication system for Dream framework" 8 | description:""" 9 | FPauth is an easy user authentication system for Dream web-framework. 10 | 11 | The main idea behind the system is that user authentication is done via running sets of Strategies, 12 | and when one of them succeeds, user is considered to be authenticated. Authentication status is controlled by a middleware 13 | standing downstream of session middleware. 14 | 15 | The system allows to: 16 | - Control authentication in web-session; 17 | - Get authentication status for each request via `Dream.field`; 18 | - Check user identity with strategies; 19 | - Use built-in strategies or custom ones; 20 | - Add all routes for authentication and strategies at once; 21 | - Add your own representations of authentication events or use built-in; 22 | - Use built-in handlers or write your own; 23 | - Extract params for authentication from requests. 24 | """ 25 | 26 | homepage: "https://github.com/mikeGEINE/FPauth" 27 | bug-reports: "https://github.com/mikeGEINE/FPauth/issues" 28 | dev-repo: "git+https://github.com/mikeGEINE/FPauth.git" 29 | 30 | authors: ["Mikhail Geine " 31 | "Pavel Argentov "] 32 | maintainer: "Mikhail Geine " 33 | 34 | build: [ 35 | ["dune" "build" "-p" name "-j" jobs] 36 | ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} 37 | ] 38 | 39 | run-test: [ 40 | ["dune" "runtest" "-p" name "-j" jobs] 41 | ] 42 | 43 | depends: [ 44 | "dream" {>="1.0.0~alpha3"} 45 | "ocaml" {>="4.12.0"} 46 | "dune" {>="2.7"} 47 | "base" 48 | "FPauth-core" {= version} 49 | "FPauth-strategies" {= version} 50 | "FPauth-responses" {= version} 51 | 52 | #Testing, development 53 | "alcotest" {with-test} 54 | "bisect_ppx" {with-test & >= "2.5.0"} # --instrument-with. 55 | "odoc" {with-doc} 56 | ] -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2022, Mikhail Geine 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy 4 | of this software and associated documentation files (the "Software"), to deal 5 | in the Software without restriction, including without limitation the rights 6 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 7 | copies of the Software, and to permit persons to whom the Software is 8 | furnished to do so, subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 15 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 16 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 17 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 18 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 19 | SOFTWARE. 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | OCAML_VERSION ?= 4.12.1 2 | 3 | .PHONY: init 4 | init: 5 | opam switch create . -y --no-install $(OCAML_VERSION) 6 | opam install . -y --deps-only 7 | opam install -y ocaml-lsp-server ocamlformat 8 | 9 | .PHONY : build 10 | build : 11 | @dune build -p dream-pure,dream-httpaf,dream --no-print-directory @install 12 | 13 | .PHONY : watch 14 | watch : 15 | @dune build -p dream-pure,dream-httpaf,dream --no-print-directory -w 16 | 17 | TEST ?= test 18 | ROOT := $(shell [ -f ../dune-workspace ] && echo .. || echo .) 19 | 20 | .PHONY : test 21 | test : 22 | @find $(ROOT) -name '*.coverage' | xargs rm -f 23 | @dune build --no-print-directory \ 24 | --instrument-with bisect_ppx --force @$(TEST)/runtest 25 | @bisect-ppx-report html 26 | @bisect-ppx-report summary 27 | @echo See _coverage/index.html 28 | 29 | .PHONY : test-watch 30 | test-watch : 31 | @dune build --no-print-directory -w @$(TEST)/runtest 32 | 33 | .PHONY : coverage-serve 34 | coverage-serve : 35 | cd _coverage && dune exec -- serve -p 8082 36 | 37 | .PHONY : promote 38 | promote : 39 | dune promote 40 | @make --no-print-directory test 41 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # FPauth - user authentication for Dream 2 | 3 | [![Coverage Status](https://coveralls.io/repos/github/mikeGEINE/FPauth/badge.svg?branch=coveralls)](https://coveralls.io/github/mikeGEINE/FPauth?branch=coveralls) 4 | 5 | FPauth is an easy user authentication system for [OCaml Dream](https://github.com/aantron/dream) web-framework. 6 | ![FPauth code example](docs/code-example.svg) 7 | 8 | The main idea behind the system is that user authentication is done via running sets of Strategies, and when one of them succeeds, user is considered to be authenticated. Authentication status is controlled by a middleware standing downstream of session middleware. 9 | 10 | The system allows to: 11 | * Control authentication in web-session; 12 | * Get authentication status for each request via `Dream.field`; 13 | * Check user identity with strategies; 14 | * Use built-in strategies or custom ones; 15 | * Add all routes for authentication and strategies at once; 16 | * Add your own representations of authentication events or use built-in; 17 | * Use built-in handlers or write your own; 18 | * Extract params for authentication from requests. 19 | 20 | Docs can be found [here](https://mikegeine.github.io/FPauth/). 21 | 22 | ## Quick setup 23 | 24 | In order to start using FPauth, in your project you should: 25 | * Initialize the system with a model of user, which suffices `FPauth.Auth_sign.MODEL`. Basically it requires functions which define, how to put and restore your users in session (`serialize` and `deserialize`), how to find users from request params (`identificate`) and which strategies can be applied to a user (`applicable_strats`); 26 | ```OCaml 27 | module Auth = FPauth.Make_Auth (User) 28 | ``` 29 | 30 | * Initialize strategies you are going to use to verify users' identities. 31 | There are some strategies in `FPauth_strategies`. `Password` can be used for password authentication, passwords are to be hashed with Argon2. `OTP` is a time-based OTP strategy, it contains routes for setting the strategy up for an already authenticated user. Strategies can have additional requirements for your models, as well as need some other modules. 32 | ```Ocaml 33 | module Password = FPauth_strategies.Password.Make (User) 34 | ``` 35 | 36 | * Add `Session_manager` middleware after your session middleware; 37 | ```OCaml 38 | let () = run 39 | @@ memory_sessions 40 | @@ Auth.Session_manager.auth_setup 41 | ``` 42 | 43 | * Insert FPauth routes into `Dream.router` middleware. Here you specify strategies used in the authentication process, the way params are extracted, responses on main authentication events. You can also specify the scope for authentication routes; 44 | ```OCaml 45 | @@ router [ 46 | Auth.Router.call [(module Password)] ~responses:(module Responses) ~extractor:extractor ~scope:"/authentication" 47 | ] 48 | ``` 49 | Strategies and Responses modules are passed as first-class objects which suffice `FPauth.Auth_sign.STRATEGY` and `FPauth.Auth_sign.RESPONSES` signatures correspondingly. Extractor is a function which meets `FPauth.Static.Params.extractor` type. 50 | * In `FPauth_responses` you can find some default responses in JSON and HTML format; 51 | * In `FPauth.Static.Params` you can find some default extractors from JSON-requests' bodies, forms or from query; 52 | * Done! Your application can now authenticate users! 53 | 54 | ## Advanced Usage 55 | It is possible to customize many aspects of the system workflow. 56 | * You can install only the packages you actually need: 57 | * `FPauth-core` contains Session_manager, Authenticator, Router, Variables, as well as Static module and signatures. These allow you to build your own workflow almost from the ground; 58 | * `FPauth-strategies` contains `Password` and `OTP` strategies. If you don't need them - you can choose not to have them 😉; 59 | * `FPauth-responses` contains some default responses on main authentication events; 60 | * You can write your own Strategies, Responses and Params Extractors. 61 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.7) -------------------------------------------------------------------------------- /src/FPauth.ml: -------------------------------------------------------------------------------- 1 | module Static = FPauth_core.Static 2 | 3 | module Auth_sign = FPauth_core.Auth_sign 4 | 5 | module Make_Auth (M : Auth_sign.MODEL) = FPauth_core.Make_Auth (M) 6 | 7 | module Strategies = FPauth_strategies 8 | 9 | module Responses = FPauth_responses -------------------------------------------------------------------------------- /src/FPauth.mli: -------------------------------------------------------------------------------- 1 | open FPauth_core 2 | 3 | (**[FPauth] is a library for easy yet customizable authentication in Dream web-applications*) 4 | 5 | (**[Static] is a module containg static type definitions, which are not dependent on {!Auth_sign.MODEL}*) 6 | module Static = Static 7 | 8 | (**[Make_Auth] creates a module based on {!Auth_sign.MODEL}. Provides local variables, middlewares and authenticator 9 | to run authentication strategies.*) 10 | module Make_Auth : 11 | functor (M : Auth_sign.MODEL) -> 12 | sig 13 | 14 | (**[Variables] contains types, functions and [local] variables based on {!Auth_sign.MODEL}.*) 15 | module Variables : Auth_sign.VARIABLES with type entity = M.t 16 | 17 | (** [SessionManager] is a module that sets local variables from session for every request via {!Auth_sign.SESSIONMANAGER.auth_setup} middleware*) 18 | module Session_manager : Auth_sign.SESSIONMANAGER with type entity = M.t 19 | 20 | (** [Authenticator] contains functions for running {!FPauth.Auth_sign.STRATEGY} list and performing logouts*) 21 | module Authenticator : Auth_sign.AUTHENTICATOR with type entity = M.t 22 | 23 | (**[Router] creates routes, needed for authentication. Contains some basic handlers and joins them with routes from strategies.*) 24 | module Router : Auth_sign.ROUTER with type entity = M.t 25 | end 26 | 27 | (**[Auth_sign] is a module containig signatures for modules which can be implemented and integrated from outside the lib, as well as signatures for some inner modules.*) 28 | module Auth_sign = Auth_sign 29 | 30 | (**[Strategies] contain two default strategies: {!FPauth_strategies.Password} and {!FPauth_strategies.Otp}*) 31 | module Strategies = FPauth_strategies 32 | 33 | (**[Responses] contain some default responses to basic authentication events*) 34 | module Responses = FPauth_responses 35 | -------------------------------------------------------------------------------- /src/core/FPauth_core.ml: -------------------------------------------------------------------------------- 1 | module Static = Static 2 | 3 | module Variables = Variables 4 | module Session_manager = Session_manager 5 | module Authenticator = Authenticator 6 | module Router = Router 7 | 8 | 9 | module Make_Auth (M : Auth_sign.MODEL) = struct 10 | 11 | module Variables = Variables.Make (M) 12 | 13 | module Session_manager = Session_manager.Make (M) (Variables) 14 | 15 | module Authenticator = Authenticator.Make (M) (Variables) 16 | 17 | module Router = Router.Make (M) (Authenticator) (Variables) 18 | end 19 | 20 | module Auth_sign = Auth_sign -------------------------------------------------------------------------------- /src/core/FPauth_core.mli: -------------------------------------------------------------------------------- 1 | (**[FPauth_core] is a library for easy yet customizable authentication in Dream web-applications*) 2 | 3 | (**[Static] is a module containg static type definitions, which are not dependent on {!Auth_sign.MODEL}*) 4 | module Static = Static 5 | 6 | module Variables = Variables 7 | module Session_manager = Session_manager 8 | module Authenticator = Authenticator 9 | module Router = Router 10 | 11 | (**[Make_Auth] creates a module based on {!Auth_sign.MODEL}. Provides local variables, middlewares and authenticator 12 | to run authentication strategies.*) 13 | module Make_Auth : 14 | functor (M : Auth_sign.MODEL) -> 15 | sig 16 | 17 | (**[Variables] contains types, functions and [local] variables based on {!Auth_sign.MODEL}.*) 18 | module Variables : Auth_sign.VARIABLES with type entity = M.t 19 | 20 | (** [SessionManager] is a module that sets local variables from session for every request via {!Auth_sign.SESSIONMANAGER.auth_setup} middleware*) 21 | module Session_manager : Auth_sign.SESSIONMANAGER with type entity = M.t 22 | 23 | (** [Authenticator] contains functions for running {!FPauth.Auth_sign.STRATEGY} list and performing logouts*) 24 | module Authenticator : Auth_sign.AUTHENTICATOR with type entity = M.t 25 | 26 | (**[Router] creates routes, needed for authentication. Contains some basic handlers and joins them with routes from strategies.*) 27 | module Router : Auth_sign.ROUTER with type entity = M.t 28 | end 29 | 30 | (**[Auth_sign] is a module containig signatures for modules which can be implemented and integrated from outside the lib, as well as signatures for some inner modules.*) 31 | module Auth_sign = Auth_sign 32 | -------------------------------------------------------------------------------- /src/core/auth_sign.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Dream 3 | 4 | (** [MODEL] is a signature for modules handling authenticable entities*) 5 | module type MODEL = sig 6 | (** Some representation of an entity to be authenticated *) 7 | type t 8 | 9 | (** [serialize] is to make a [string] from [t] to store in a session between requests. It should represent entity 10 | in a way allowing to regain it later with {!val:deserialize}*) 11 | val serialize : t -> string 12 | 13 | (** [deserialize] is to make [t] from [string] to use it in handlers. The [string] should be created by {!val:serialize}. 14 | Returns: [Ok t] if deserialization was successful or [Error string] if an error occured*) 15 | val deserialize : string -> (t, Error.t) Result.t 16 | 17 | (**[identificate] is to define which user is trying to authenticate. Retrieves its representation or returns an error*) 18 | val identificate : request -> (t, Error.t) Result.t promise 19 | 20 | (**[applicable_strats] returns a list of strats which can be applied to the whole [MODEL] or to certain {!t}. 21 | Strings are to be the same as {!STRATEGY.name} *) 22 | val applicable_strats : t -> string list 23 | end 24 | 25 | (** [SESSIONMANAGER] is a signature for a functor producing modules for controlling sessions and 26 | authentications of entities with type {!MODEL.t}*) 27 | module type SESSIONMANAGER = sig 28 | (** type [entity] is a type of authenticatable entity equal to {!MODEL.t}*) 29 | type entity 30 | 31 | (**[auth_setup] is a middleware which controlls session, setups [field] variables and helper functions for downstream handlers*) 32 | val auth_setup : middleware 33 | (** [auth_setup] tries to extract [auth] string from session and determine the status of authentication. 34 | If there is no [auth], then there were no authentication. 35 | If [auth] exisits, than {!set_helpers} checks it and manages authentication status. If something is wrong with a session, 36 | [Error Error.t] is returned, and in this case session is invalidated, error is logged and 401 is sent. 37 | If session is ok, [Ok request] is recived, and that requested is passed on. *) 38 | end 39 | 40 | (**[STRATEGY] is a module which contains functions for entity authentications in a certain method, as well as supporting routes and functions*) 41 | module type STRATEGY = sig 42 | (** type [entity] is a type of authenticatable entity equal to {!MODEL.t}*) 43 | type entity 44 | 45 | (**[call] is a core function of a strategy. It determines ways of authenticating an entity*) 46 | val call : request -> entity -> entity Static.StratResult.t Lwt.t 47 | 48 | (**[routes] defines some additional routes to handlers of a strategy if they are needed. Can contain multiple routes using [Dream.scope]*) 49 | val routes : route 50 | 51 | (**[name] is a name of the STRATEGY. Used to define wether the strat can be applied to a certain entity.*) 52 | val name : string 53 | end 54 | 55 | (** [AUTHENTICATOR] is a signature for a functor to create authenticators of various entities over various strategies (See {!STRATEGY})*) 56 | module type AUTHENTICATOR = sig 57 | (** type [entity] is a type of authenticatable entity equal to {!MODEL.t}*) 58 | type entity 59 | 60 | (** [strategy] is a function that authenticates an entity from a request.*) 61 | type strategy = (module STRATEGY with type entity = entity) 62 | 63 | (**[authenticate] runs several authentication strategies for a request and defines, whether overall authentication was successful or not*) 64 | val authenticate : strategy list -> request -> Static.AuthResult.t promise 65 | 66 | (**[logout] invalidates session, which resets authentication status to [false]*) 67 | val logout : Dream.request -> unit Lwt.t 68 | end 69 | 70 | (** [VARIABLES] is a module containing field variables based on {!MODEL}*) 71 | module type VARIABLES = sig 72 | (** type [entity] is a type of authenticatable entity equal to {!MODEL.t}*) 73 | type entity 74 | 75 | (** [authenticated] is a variable valid for a single request, indicates if authentication has been previously completed. 76 | Should be set in {!SESSIONMANAGER.auth_setup}*) 77 | val authenticated : bool field 78 | 79 | (**[current_user] is a variable valid for a single request, holds an authenticated entity from a session. 80 | Should be set in {!SESSIONMANAGER.auth_setup}*) 81 | val current_user : entity field 82 | 83 | (** [auth_error] is a field with error which occured during any stage of authentication*) 84 | val auth_error : Error.t field 85 | 86 | (**[update_current_user user request] updates {!current_user} and session.*) 87 | val update_current_user : entity -> request -> unit promise 88 | end 89 | 90 | (** [RESPONSES] is a module which defines how the library should represent some basic events*) 91 | module type RESPONSES = sig 92 | (**[login_successful] is triggered when authentication has been successful*) 93 | val login_successful : request -> response promise 94 | 95 | (**[login_error] is triggered if there was any kind of failure during authentication*) 96 | val login_error : request -> response promise 97 | 98 | (**[logout] is triggered after authentication has been reset*) 99 | val logout : request -> response promise 100 | end 101 | 102 | (**[ROUTER] is a module which contains handlers for authentication and creates routes for them.*) 103 | module type ROUTER = sig 104 | (** type [entity] is a type of authenticatable entity equal to {!MODEL.t}*) 105 | type entity 106 | 107 | (** [strategy] is a function that authenticates an entity from a request.*) 108 | type strategy = (module STRATEGY with type entity = entity) 109 | 110 | (**[login_handler] gets strats and redponses, starts authentication and handles its results*) 111 | val login_handler : 112 | strategy list -> 113 | (module RESPONSES) -> Dream.request -> Dream.response Lwt.t 114 | 115 | (**[logout_handler] loguts authenticated user*) 116 | val logout_handler : 117 | (module RESPONSES) -> Dream.request -> Dream.response Lwt.t 118 | 119 | (**[call ?root ~responses ~extractor strat_list] creates routes for authentication and added to [Dream.router]. 120 | 121 | Has some basic routes: 122 | 123 | - "/auth" is an entrypoint for authentication. Runs all [strategies] in order they were supplied in {!Auth_sign.AUTHENTICATOR.authenticate}. Handles the results and calls corresponding handlers from {!Auth_sign.RESPONSES}. 124 | - "/logout" completes logout with {!Authenticator.logout} and responses with {!Auth_sign.RESPONSES.logout} 125 | 126 | [extractor] defines how to extract params from requests for basic routes. See {!Static.Params.extractor}. 127 | 128 | [responses] define how to respond on these basic routes after handling authentication processes. 129 | 130 | [?root] defines the root for all authentication-related routes. Default is "/".*) 131 | val call : 132 | ?root:string -> 133 | responses:(module RESPONSES) -> 134 | extractor:Static.Params.extractor -> strategy list -> Dream.route 135 | end 136 | -------------------------------------------------------------------------------- /src/core/authenticator.ml: -------------------------------------------------------------------------------- 1 | (**[Authenticator] is module which provides functions both for authentication and logout*) 2 | 3 | open Base 4 | open Dream 5 | open Static 6 | 7 | (**[Make] creates an instance of {!Auth_sign.AUTHENTICATOR} for a given model and variables*) 8 | module Make (M : Auth_sign.MODEL) (V : Auth_sign.VARIABLES with type entity = M.t ) : (Auth_sign.AUTHENTICATOR with type entity = M.t) = struct 9 | 10 | type entity = M.t 11 | 12 | (** [strategy] is a function that tries to authenticate an entity*) 13 | type strategy = (module Auth_sign.STRATEGY with type entity = entity) 14 | 15 | module type Strategy = Auth_sign.STRATEGY with type entity = entity 16 | 17 | let set_authenticated request = 18 | set_field request V.authenticated true; 19 | request 20 | 21 | (**[auth] is a recursive function for running strategies and verifying*) 22 | let rec auth (lst : strategy list) request ent : AuthResult.t promise = 23 | match lst with 24 | | [] -> set_field request V.auth_error (Error.of_string "End of strategy list"); 25 | Lwt.return AuthResult.Rescue 26 | | (module S : Strategy)::strats -> 27 | match%lwt S.call request ent with 28 | | Next -> auth strats request ent 29 | | Authenticated ent -> 30 | let%lwt () = 31 | request |> set_authenticated |> V.update_current_user ent in 32 | Lwt.return AuthResult.Authenticated 33 | | Rescue err -> set_field request V.auth_error err; 34 | Lwt.return AuthResult.Rescue 35 | | Redirect url -> Lwt.return (AuthResult.Redirect url) 36 | 37 | 38 | let name_in_list names (module S : Strategy) = 39 | List.exists names ~f:(String.equal S.name) 40 | 41 | let filter_strategies (strats: strategy list) names = 42 | List.filter strats ~f:(name_in_list names) 43 | 44 | (** [authenticate] runs all strategies from the list until one of them succeeds. 45 | Sets session and field variables. Returns a promise. *) 46 | let authenticate (lst : strategy list) request = 47 | match%lwt M.identificate request with 48 | | Error err -> set_field request V.auth_error err; 49 | Lwt.return AuthResult.Rescue 50 | | Ok ent -> 51 | let filtered_strats = M.applicable_strats ent |> filter_strategies lst in 52 | auth filtered_strats request ent 53 | 54 | (** [logout] clears [auth] session field and sets {V.authenticated} to [false], making session unauthenticated. 55 | Note: the function does NOT modify {!V.current_user}. It will be set to [None] only for the next request.*) 56 | let logout request = 57 | set_field request V.authenticated false; 58 | request |> invalidate_session 59 | end -------------------------------------------------------------------------------- /src/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FPauth_core) 3 | (public_name FPauth-core) 4 | (libraries base dream) 5 | (preprocess 6 | (pps lwt_ppx)) 7 | (instrumentation (backend bisect_ppx))) 8 | -------------------------------------------------------------------------------- /src/core/router.ml: -------------------------------------------------------------------------------- 1 | (**[Router] is a module which contains handlers for authentication and creates routes for them.*) 2 | 3 | open Dream 4 | open Base 5 | 6 | (**[Make] creates an instance of Router with all its dependencies*) 7 | module Make (M : Auth_sign.MODEL) 8 | (A : Auth_sign.AUTHENTICATOR with type entity = M.t) 9 | (V : Auth_sign.VARIABLES) : (Auth_sign.ROUTER with type entity = M.t) = struct 10 | 11 | type entity = M.t 12 | 13 | type strategy = (module Auth_sign.STRATEGY with type entity = entity) 14 | 15 | let login_handler (strat_list : A.strategy list) (module R : Auth_sign.RESPONSES) request = 16 | match%lwt A.authenticate strat_list request with 17 | | Authenticated -> R.login_successful request 18 | | Rescue-> R.login_error request 19 | | Redirect url -> url 20 | 21 | let logout_handler (module R : Auth_sign.RESPONSES) request = 22 | let%lwt () = A.logout request in 23 | R.logout request 24 | 25 | let strategy_routes strat_list = 26 | let rec extractor acc = function 27 | | [] -> acc 28 | | strat::strats -> let module S = (val strat : Auth_sign.STRATEGY with type entity = M.t) in 29 | extractor ((S.routes)::acc) strats 30 | in 31 | extractor [] strat_list |> List.rev 32 | 33 | let call ?(root="/") ~responses ~extractor strat_list = 34 | let strat_routes = strategy_routes strat_list in 35 | let all_routes = List.append [ 36 | post "/auth" (login_handler strat_list responses); 37 | get "/auth" (login_handler strat_list responses); 38 | post "/logout" (logout_handler responses); 39 | get "/logout" (logout_handler responses); 40 | ] strat_routes in 41 | scope root [Static.Params.set_params ~extractor] all_routes 42 | end 43 | -------------------------------------------------------------------------------- /src/core/session_manager.ml: -------------------------------------------------------------------------------- 1 | (**[Session_manager] contains*) 2 | 3 | open Base 4 | open Dream 5 | open Lwt.Syntax 6 | 7 | (** [Make] is a functor for creating modules of middlewares for various entities matching {!Auth.MODEL}*) 8 | module Make (M : Auth_sign.MODEL) (V :Auth_sign.VARIABLES with type entity = M.t) : (Auth_sign.SESSIONMANAGER with type entity = M.t) = struct 9 | 10 | type entity = M.t 11 | 12 | (** [set_helpers] sets field variables for a request and manages authentication status in case if [auth] is in a session. 13 | - If [serialized] is empty, then [Error Error.t] is returned, as it is abnormal situation. 14 | - If {!M.deserialize} ended up with an [Error Error.t], then authentication is incomplete and {!auth_session_error} is set with the sting. 15 | - If {!M.deserialize} ended with [Ok M.t], then authentication is considered successful and {!current_user} is set.*) 16 | let set_helpers serialized request = 17 | if String.equal serialized "" then 18 | Error (Error.of_string "Auth session field is empty") 19 | else match M.deserialize serialized with 20 | | Ok ent -> 21 | set_field request V.authenticated true; 22 | set_field request V.current_user ent; 23 | Ok request 24 | | Error err -> 25 | Error err 26 | 27 | (** [auth_setup] tries to extract [auth] string from session and determine the status of authentication. 28 | If there is no [auth], then there were no authentication. 29 | If [auth] exisits, than {!set_helpers} checks it and manages authentication status. If something is wrong with a session, 30 | [Error Error.t] is returned, and in this case session is invalidated, error is logged and 401 is sent. 31 | If session is ok, [Ok request] is recived, and that requested is passed on. *) 32 | let auth_setup (inner_handler : handler) (request : request) = 33 | match session "auth" request with 34 | | None -> set_field request V.authenticated false; inner_handler request 35 | | Some serialized -> 36 | match set_helpers serialized request with 37 | | Ok req -> inner_handler req 38 | | Error err -> 39 | Dream.error (fun log -> Error.to_string_mach err |> log ~request "Session auth error: %s"); 40 | let* () = request |> invalidate_session 41 | in 42 | respond ~status:`Unauthorized "" 43 | end 44 | -------------------------------------------------------------------------------- /src/core/static.ml: -------------------------------------------------------------------------------- 1 | open Dream 2 | open Base 3 | 4 | module StratResult = struct 5 | type 'a t = 6 | | Authenticated of 'a 7 | | Rescue of Error.t 8 | | Redirect of response promise 9 | | Next 10 | 11 | let bind r f = 12 | match r with 13 | | Authenticated x -> f x 14 | | Rescue err -> Rescue err 15 | | Next -> Next 16 | | Redirect url -> Redirect url 17 | 18 | module Infix = struct 19 | let (>>==) = bind 20 | end 21 | end 22 | 23 | module AuthResult = struct 24 | type t = 25 | | Authenticated 26 | | Rescue 27 | | Redirect of response promise 28 | end 29 | 30 | module Params = struct 31 | (** [params] is a map of strings, which serves as a representation of data in a [request]*) 32 | type t = (string * string) list 33 | 34 | let params_field : t field = new_field () 35 | 36 | let params request = field request params_field 37 | 38 | (**[extract_params] is a function which transforms [request] into [(string * string) list] and wraps it in promise. The list is than used for authentication*) 39 | type extractor = request -> t promise 40 | 41 | (** [get_param] tries to retrieve a value binded with [key] in [params]. Returns the value in an option*) 42 | let get_param key params = List.Assoc.find params ~equal:(String.equal) key 43 | 44 | (**[get_param_exn] behaves similar to {!get_param}, but returns an exeption if there is no a bind with the [key]*) 45 | let get_param_exn key params = List.Assoc.find_exn params ~equal:(String.equal) key 46 | 47 | let get_param_req key request = 48 | match params request with 49 | |None -> None 50 | |Some prms -> get_param key prms 51 | 52 | let of_assoc (lst:(string * string) list) : t = lst 53 | 54 | (**[extract_query] is an example of {!extract_params} for working with query params of a request*) 55 | let extract_query request = all_queries request |> Lwt.return 56 | 57 | (**[extract_json] is an example of {!extract_params} for working with json-body requests*) 58 | let extract_json request = 59 | let rec val_to_str acc = function 60 | | (k, v) :: t -> val_to_str ((k, Yojson.Safe.Util.to_string v)::acc) t 61 | | [] -> acc 62 | in 63 | let content = header request "Content-Type" in 64 | match content with 65 | | Some "application/json" -> 66 | let%lwt body' = body request in 67 | Yojson.Safe.from_string body' |> Yojson.Safe.Util.to_assoc |> val_to_str [] |> Lwt.return 68 | | _ -> of_assoc [] |> Lwt.return 69 | 70 | let extract_form ?(csrf=true) request = 71 | let content = header request "Content-Type" in 72 | match content with 73 | | Some "application/x-www-form-urlencoded" -> begin 74 | match%lwt Dream.form ~csrf request with 75 | |`Ok lst -> of_assoc lst |> Lwt.return 76 | | _ -> of_assoc [] |> Lwt.return 77 | end 78 | | _ -> of_assoc [] |> Lwt.return 79 | 80 | 81 | 82 | let set_params ~(extractor:extractor) (inner_handler : Dream.handler) request = 83 | let%lwt extracted = extractor request in 84 | set_field request params_field extracted; 85 | inner_handler request 86 | end 87 | -------------------------------------------------------------------------------- /src/core/static.mli: -------------------------------------------------------------------------------- 1 | (**[Static] is a module containing all FPauth features, which are not dependant on {!FPauth.Auth_sign.MODEL}*) 2 | 3 | open Dream 4 | 5 | (** [StratResult] defines results of strategies, as well as some helpful functions. *) 6 | module StratResult : 7 | sig 8 | 9 | (**['a t] defines results of strategies.*) 10 | type 'a t = 11 | Authenticated of 'a (**Entity has been authenticated successfully. Can also be used inside a strategy with bind like [Ok 'a] result. When returned to {!FPauth.Auth_sign.AUTHENTICATOR} stops authentication process.*) 12 | | Rescue of Base.Error.t (**Authentication must be stopped immediately with an error.*) 13 | | Redirect of response Lwt.t (**User should be redirected in accordance with [response]. [response promise] is meant to be created by [Dream.redirect]*) 14 | | Next (**Next strategy from the list in {!FPauth.Auth_sign.AUTHENTICATOR} should be used.*) 15 | 16 | (**[bind r f] returns [f r] if [r] is {!Authenticated} and [r] if anything else*) 17 | val bind : 'a t -> ('a -> 'b t) -> 'b t 18 | 19 | (**Module with Infix operators for [StratResult]*) 20 | module Infix : 21 | sig 22 | (**Infix operator for {!FPauth.Static.StratResult.bind}*) 23 | val ( >>== ) : 'a t -> ('a -> 'b t) -> 'b t 24 | end 25 | end 26 | 27 | (**[AuthResult] is a result of full authentication process. Similar to {!StratResult}, but doesn't have some types which are meaningful only for strategies. 28 | [Authenticated] and [Rescue] loose content as it is stored in [Dream.field] by the end of authentication*) 29 | module AuthResult : 30 | sig 31 | type t = 32 | Authenticated (**Entity has been authenticated successfully.*) 33 | | Rescue (**Authentication must be stopped immediately with an error.*) 34 | | Redirect of Dream.response Lwt.t (**User should be redirected in accordance with [response]. [response promise] is meant to be created by [Dream.redirect]*) 35 | end 36 | 37 | (**[Params] stores params of a request, either all or only required for authentication*) 38 | module Params : 39 | sig 40 | type t 41 | 42 | (**[params request] returns {!t} option if params were previously extracted for the request by {!set_params} middleware.*) 43 | val params : request -> t option 44 | 45 | (**[extractor] is a type of function which turns requests into params *) 46 | type extractor = request -> t Lwt.t 47 | 48 | (**[get_param key params] searches for a given [key] in [params] and returns [Some str] if it is present or [None] if it is not.*) 49 | val get_param : string -> t -> string option 50 | 51 | (**[get_param_exn key params] is the same as {!get_param}, but returns an exeption if the [key] is not present *) 52 | val get_param_exn : string -> t -> string 53 | 54 | (**[get_param_req key request] is a shortcut for [params request >>= get_param key]. *) 55 | val get_param_req : string -> request -> string option 56 | 57 | (**[extract_query request] extracts all query params of a request and returns them as params*) 58 | val extract_query : extractor 59 | 60 | (**[extract_json request] extracts all pairs of keys and values of a JSON request. {b Content-Type} must be [application/json].*) 61 | val extract_json : extractor 62 | 63 | (**[extract_form request] extracts params from forms send with [Dream.csrf_tag]. {b Content-Type} must be [application/x-www-form-urlencoded].*) 64 | val extract_form : ?csrf:bool -> extractor 65 | 66 | (**[of_assoc lst] creates [t] from assoc lists*) 67 | val of_assoc : (string * string) list -> t 68 | 69 | (**[ser_params ~extractor] is a middleware which sets params for a request, extracting them using [~extractor].*) 70 | val set_params : extractor:extractor -> handler -> request -> response promise 71 | end 72 | -------------------------------------------------------------------------------- /src/core/variables.ml: -------------------------------------------------------------------------------- 1 | (**[VARIABLES] is a module which inits and holds field variables for authentication*) 2 | 3 | open Dream 4 | open Base 5 | 6 | (**[Make] creates an instance of {!Auth_sign.VARIABLES} for a given model*) 7 | module Make (M : Auth_sign.MODEL) : (Auth_sign.VARIABLES with type entity = M.t) = struct 8 | type entity = M.t 9 | 10 | let authenticated : bool field = new_field () 11 | 12 | let current_user : entity field = new_field () 13 | 14 | let auth_error : Error.t field = new_field () 15 | 16 | let update_current_user updated_user request = 17 | set_field request current_user updated_user; 18 | put_session "auth" (M.serialize updated_user) request 19 | end -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name FPauth) 3 | (libraries dream base FPauth-core FPauth-strategies FPauth-responses) 4 | (preprocess 5 | (pps lwt_ppx)) 6 | (instrumentation (backend bisect_ppx))) 7 | -------------------------------------------------------------------------------- /src/responses/FPauth_responses.ml: -------------------------------------------------------------------------------- 1 | module JSON = JSON 2 | module HTML = HTML 3 | -------------------------------------------------------------------------------- /src/responses/HTML.ml: -------------------------------------------------------------------------------- 1 | (**This module contains responses for basic FPauth events in HTML format.*) 2 | 3 | open Base 4 | open Dream 5 | 6 | (**This module contains such settings as app name for titles *) 7 | module type HTML_settings = sig val app_name : string end 8 | 9 | (**[Make] creates HTML responses module with all required rependencies*) 10 | module Make (V : FPauth_core.Auth_sign.VARIABLES) (S : HTML_settings) : FPauth_core.Auth_sign.RESPONSES = struct 11 | let login_successful req = 12 | let auth = Option.value_exn (field req V.authenticated) in 13 | Html_pages.login_successful_tmpl ~app_name:S.app_name auth |> html 14 | 15 | let login_error req = 16 | let err = Option.value_exn (field req V.auth_error) |> Error.to_string_mach in 17 | Html_pages.login_error_tmpl ~app_name:S.app_name err |> html 18 | 19 | let logout req = 20 | let auth = Option.value_exn (field req V.authenticated) in 21 | Html_pages.logout_tmpl ~app_name:S.app_name auth |> html 22 | end 23 | 24 | (**[make_responses ?app_name (Variables)] is a convinience function for creating HTML response module without {!HTML_settings}. 25 | Returns first-class module.*) 26 | let make_responses ?(app_name="FPauth") (module V : FPauth_core.Auth_sign.VARIABLES) = 27 | let module S = (struct let app_name = app_name end) in 28 | let module HTML = Make (V) (S) in 29 | (module HTML : FPauth_core.Auth_sign.RESPONSES) -------------------------------------------------------------------------------- /src/responses/JSON.ml: -------------------------------------------------------------------------------- 1 | (**This module contains responses for basic FPauth events in JSON format.*) 2 | 3 | open Dream 4 | open Base 5 | 6 | (**[Make] creates responses for provided Variables*) 7 | module Make (Variables : FPauth_core.Auth_sign.VARIABLES) : (FPauth_core.Auth_sign.RESPONSES) = struct 8 | 9 | let login_successful request = 10 | let auth = Option.value_exn (field request Variables.authenticated) |> Bool.to_string in 11 | json ("{\"authenticated\" : "^ auth ^" }") 12 | 13 | 14 | let login_error request = 15 | let err = field request (Variables.auth_error) |> Option.value ~default:(Error.of_string "Unknown error") |> Error.to_string_mach 16 | and auth = Option.value_exn (field request Variables.authenticated) |> Bool.to_string in 17 | json ("{\"auth\" : "^ auth ^", \n 18 | \"error\" : "^ err ^"}") 19 | 20 | let logout request = 21 | match field request Variables.authenticated with 22 | | None -> json ("{\"error\" : \"No local\"}") 23 | | Some auth -> json ("{ 24 | \"auth\" : "^( auth |> Bool.to_string)^"}") 25 | end 26 | -------------------------------------------------------------------------------- /src/responses/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FPauth_responses) 3 | (public_name FPauth-responses) 4 | (libraries base FPauth-core dream) 5 | (preprocess 6 | (pps lwt_ppx))) 7 | 8 | (rule 9 | (deps html_pages.eml.ml) 10 | (targets html_pages.ml) 11 | (action (run dream_eml %{deps} --workspace %{workspace_root}))) 12 | -------------------------------------------------------------------------------- /src/responses/html_pages.eml.ml: -------------------------------------------------------------------------------- 1 | let login_successful_tmpl ?(app_name="FPauth") auth = 2 | 3 | 4 | 5 | 6 | <%s app_name^" login successful"%> 7 | 8 | 9 |
Authentication status: <%s Bool.to_string auth%>
10 | 11 | 12 | 13 | let login_error_tmpl ?(app_name="FPauth") err = 14 | 15 | 16 | 17 | 18 | <%s app_name^" login error"%> 19 | 20 | 21 |
Authentication error: <%s err%>
22 | 23 | 24 | 25 | let logout_tmpl ?(app_name="FPauth") auth = 26 | 27 | 28 | 29 | 30 | <%s app_name^" logout"%> 31 | 32 | 33 |
Authentication status: <%s Bool.to_string auth%>
34 | 35 | -------------------------------------------------------------------------------- /src/strategies/FPauth_strategies.ml: -------------------------------------------------------------------------------- 1 | module Password = Password 2 | 3 | module TOTP = TOTP -------------------------------------------------------------------------------- /src/strategies/TOTP.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open FPauth_core.Static 3 | open FPauth_core.Static.StratResult.Infix 4 | 5 | let name = "TOTP" 6 | 7 | module type MODEL = sig 8 | type t 9 | 10 | val otp_secret : t -> string 11 | 12 | val otp_enabled : t -> bool 13 | 14 | val set_otp_secret: Dream.request -> t -> string -> t Dream.promise 15 | 16 | val set_otp_enabled: Dream.request -> t -> bool -> t Dream.promise 17 | end 18 | 19 | module type RESPONSES = sig 20 | open Dream 21 | 22 | val response_error : request -> Error.t -> response promise 23 | 24 | val response_secret : request -> string -> response promise 25 | 26 | val response_enabled : request -> response promise 27 | end 28 | 29 | module Make (R : RESPONSES) (M : MODEL) (V : FPauth_core.Auth_sign.VARIABLES with type entity = M.t) 30 | : (FPauth_core.Auth_sign.STRATEGY with type entity = M.t) = struct 31 | open R 32 | 33 | type entity = M.t 34 | 35 | 36 | let is_enabled user = 37 | match M.otp_enabled user with 38 | | false -> StratResult.Next 39 | | true -> Authenticated user 40 | 41 | let extract_otp request _ = 42 | match Params.get_param_req "totp_code" request with 43 | | None -> Dream.log "\'totp_code\' is needed for TOTP authentication, skipping the strategy..."; 44 | StratResult.Next 45 | | Some otp_code -> Authenticated otp_code 46 | 47 | let verify_otp user otp_code = 48 | let secret = M.otp_secret user in 49 | match Twostep.TOTP.verify ~secret:secret ~code:otp_code () with 50 | | false -> StratResult.Rescue (Error.of_string ("One-time password is incorrect!")) 51 | | true -> Authenticated user 52 | 53 | 54 | let call request user = 55 | is_enabled user >>== extract_otp request >>== verify_otp user |> Lwt.return 56 | 57 | let generate_secret request = 58 | match Dream.field request V.current_user with 59 | | None -> Error.of_string "User should be authenticated first" |> response_error request 60 | | Some user -> 61 | match M.otp_enabled user with 62 | | true -> Error.of_string "OTP is already enabled" |> response_error request 63 | | false -> 64 | let secret = Twostep.TOTP.secret () in 65 | let%lwt updated_user = M.set_otp_secret request user secret in 66 | let%lwt () = V.update_current_user updated_user request in 67 | response_secret request secret 68 | 69 | let finish_setup request = 70 | match Dream.field request V.current_user with 71 | | None -> Error.of_string "User should be authenticated first" |> response_error request 72 | | Some user -> 73 | match M.otp_enabled user with 74 | | true -> Error.of_string "OTP is already enabled" |> response_error request 75 | | false -> 76 | match Params.get_param_req "totp_code" request with 77 | | None -> Error.of_string "\'TOTP code\' param not found in request" |> response_error request 78 | | Some otp_code -> 79 | let secret = M.otp_secret user in 80 | match Twostep.TOTP.verify ~secret:secret ~code:otp_code () with 81 | | false -> Error.of_string "One-time password is incorrect!" |> response_error request 82 | | true -> 83 | let%lwt updated_user = M.set_otp_enabled request user true in 84 | let%lwt () = V.update_current_user updated_user request in 85 | response_enabled request 86 | 87 | let routes = 88 | Dream.scope "/totp" [] [ 89 | Dream.get "/generate_secret" generate_secret; 90 | Dream.post "/finish_setup" finish_setup 91 | ] 92 | 93 | let name = name 94 | end 95 | 96 | module JSON_Responses : RESPONSES = struct 97 | let response_error _ err = 98 | Dream.json ("{\"success\" : false, \n 99 | \"error\" : "^Error.to_string_mach err^"}") 100 | 101 | let response_secret _ secret = 102 | Dream.json ("{\"success\" : true, \n 103 | \"secret\" : \""^ secret ^"\" }") 104 | 105 | let response_enabled _ = 106 | Dream.json ("{\"TOTP enabled\" : true}") 107 | end 108 | 109 | (**This module contains such settings as app name for titles *) 110 | module type HTML_settings = sig val app_name : string end 111 | 112 | module Make_HTML_Responses (S : HTML_settings) : RESPONSES = struct 113 | let response_error _ err = 114 | let err_str = Error.to_string_mach err in 115 | TOTP_pages.error_tmpl ~app_name:S.app_name err_str |> Dream.html 116 | 117 | let response_secret request secret = 118 | let target = Dream.target request |> String.substr_replace_first ~pattern:"/generate_secret" ~with_:"/finish_setup" in 119 | TOTP_pages.secret_tmpl ~app_name:S.app_name request target secret |> Dream.html 120 | 121 | let response_enabled _ = 122 | TOTP_pages.finish_tmpl ~app_name:S.app_name () |> Dream.html 123 | end 124 | 125 | (**[make_responses ?app_name (Variables)] is a convinience function for creating HTML response module without {!HTML_settings}. 126 | Returns first-class module.*) 127 | let make_html_responses ?(app_name="FPauth") () = 128 | let module S = (struct let app_name = app_name end) in 129 | let module HTML = Make_HTML_Responses (S) in 130 | (module HTML : RESPONSES) -------------------------------------------------------------------------------- /src/strategies/TOTP.mli: -------------------------------------------------------------------------------- 1 | (**[TOTP] is a time-based One-Time Password strategy. User's identity is verified via a password which is limited for a limited time only.*) 2 | 3 | (** Requires {b "totp_code" param}, otherwise skipped. 4 | Provides these routes in "/totp" scope: 5 | - GET "/generate_secret" is the first step to enable TOTP. Generates a secret for a user. The user must be authenticated first. The user must have TOTP disabled. 6 | - POST "/finish_setup" is the second step to enable TOTP. Should recieve "totp_code" as param, verifies it and enables TOTP if it was correct.*) 7 | 8 | (**Name of the strategy.*) 9 | val name : string 10 | 11 | (**[MODEL] contains requirements for user model in order to use the strategy*) 12 | module type MODEL = 13 | sig 14 | type t 15 | 16 | (**Retrieves secret for TOTP for the user*) 17 | val otp_secret : t -> string 18 | 19 | (**Checks if TOTP has already been setup for the user. 20 | Returns: true if the user can use TOTP strategy.*) 21 | val otp_enabled : t -> bool 22 | 23 | (**Sets TOTP secret during setup. Returns updated user.*) 24 | val set_otp_secret : Dream.request -> t -> string -> t Lwt.t 25 | 26 | (**Enables TOTP. Returns updated user.*) 27 | val set_otp_enabled : Dream.request -> t -> bool -> t Lwt.t 28 | end 29 | 30 | (**[RESPONSES] contains data representations for certain events*) 31 | module type RESPONSES = 32 | sig 33 | (**This response is used to display all kinds of errors*) 34 | val response_error : Dream.request -> Base.Error.t -> Dream.response Lwt.t 35 | 36 | (**This response is used during TOTP setup. During this step users are provided with a secret, which he needs to put in his OTP-generator.*) 37 | val response_secret : Dream.request -> string -> Dream.response Lwt.t 38 | 39 | (**This response informs users that their TOTP has been enabled*) 40 | val response_enabled : Dream.request -> Dream.response Lwt.t 41 | end 42 | 43 | (**[Make] creates a strategy for a provided model with provided responses.*) 44 | module Make : 45 | functor (R : RESPONSES) (M : MODEL) 46 | (V : FPauth_core.Auth_sign.VARIABLES with type entity = M.t) 47 | -> 48 | sig 49 | type entity = M.t 50 | 51 | (**[call] is the main function of the strategy. It needs "totp_code" param, otherwise it is skipped. Verifies, that the code is correct for user's secret.*) 52 | val call : 53 | Dream.request -> 54 | entity -> entity FPauth_core.Static.StratResult.t Lwt.t 55 | 56 | (**[routes] provide these routes in "/totp" scope: 57 | - GET "/generate_secret" is the first step to enable TOTP. Generates a secret for a user. The user must be authenticated first. The user must have TOTP disabled. 58 | - POST "/finish_setup" is the second step to enable TOTP. Should recieve "totp_code" as param, verifies it and enables TOTP if it was correct.*) 59 | val routes : Dream.route 60 | 61 | (**See {!TOTP.name}*) 62 | val name : string 63 | end 64 | 65 | (**Module with responses for TOTP in JSON format*) 66 | module JSON_Responses : RESPONSES 67 | 68 | (**This module contains such settings as app name for titles *) 69 | module type HTML_settings = sig val app_name : string end 70 | 71 | (**This functor creates module with {!RESPONSES} in HTML format*) 72 | module Make_HTML_Responses : functor (S : HTML_settings) -> RESPONSES 73 | 74 | (**[make_html_responses ~app_name ()] is a convinience function for creating HTML response module without {!HTML_settings}. 75 | Returns first-class module.*) 76 | val make_html_responses : ?app_name:string -> unit -> (module RESPONSES) 77 | -------------------------------------------------------------------------------- /src/strategies/TOTP_pages.eml.ml: -------------------------------------------------------------------------------- 1 | let error_tmpl ~app_name err = 2 | 3 | 4 | 5 | 6 | <%s app_name^" TOTP error"%> 7 | 8 | 9 |
TOTP setup error: <%s err%>
10 | 11 | 12 | 13 | let secret_tmpl ~app_name request form_url secret = 14 | 15 | 16 | 17 | 18 | <%s app_name^" TOTP secret"%> 19 | 20 | 21 |
22 |

TOTP secret: <%s secret%>

23 |

Add this secret in your code-generating app (like Google Authenticator).

24 |
25 |
> 26 | <%s! Dream.csrf_tag request %> 27 | 28 | 29 |
30 | 31 | 32 | 33 | let finish_tmpl ~app_name () = 34 | 35 | 36 | 37 | 38 | <%s app_name^" TOTP finished"%> 39 | 40 | 41 |
TOTP setup finished. You can now send Time-based One-time passwords for authentication.
42 | 43 | -------------------------------------------------------------------------------- /src/strategies/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name FPauth_strategies) 3 | (public_name FPauth-strategies) 4 | (libraries base FPauth-core argon2 twostep) 5 | (preprocess 6 | (pps lwt_ppx)) 7 | (instrumentation (backend bisect_ppx))) 8 | 9 | (rule 10 | (deps TOTP_pages.eml.ml) 11 | (targets TOTP_pages.ml) 12 | (action (run dream_eml %{deps} --workspace %{workspace_root}))) 13 | -------------------------------------------------------------------------------- /src/strategies/password.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open FPauth_core.Static 3 | 4 | 5 | let name = "password" 6 | module type MODEL = sig 7 | (** Some representation of an entity to be authenticated *) 8 | type t 9 | 10 | (** [encrypted_password] retrieves password of an entity in an encrypted form*) 11 | val encrypted_password: t -> string option 12 | end 13 | 14 | module Make (M : MODEL) : (FPauth_core.Auth_sign.STRATEGY with type entity = M.t) = struct 15 | 16 | open StratResult 17 | open StratResult.Infix 18 | 19 | type entity = M.t 20 | let get_password request = 21 | match Params.get_param_req "password" request with 22 | | None -> Dream.log "\'password\' is needed for Password authentication, skipping the strategy..."; Next 23 | | Some password -> Authenticated password 24 | 25 | let check_password user password = 26 | match M.encrypted_password user with 27 | | None -> Rescue (Error.of_string "No encrypted password for the user") 28 | | Some encoded -> 29 | match Argon2.verify ~encoded ~pwd:password ~kind:Argon2.ID with 30 | | Error Argon2.ErrorCodes.VERIFY_MISMATCH -> Rescue (Error.of_string "Incorrect password!") 31 | | Error err -> Rescue (Error.of_string (Argon2.ErrorCodes.message err)) 32 | | Ok _ -> Authenticated user 33 | 34 | 35 | (**[call] is a main function of a strategy, which authenticates the user by "login" and "password" querry params*) 36 | let call request user = 37 | get_password request >>== check_password user |> Lwt.return 38 | 39 | let routes = Dream.no_route 40 | 41 | (* takes name from outside the functor*) 42 | let name = name 43 | end 44 | 45 | -------------------------------------------------------------------------------- /src/strategies/password.mli: -------------------------------------------------------------------------------- 1 | (**[Password] is a simple authentication strategy which verifies identity via provided in params password.*) 2 | 3 | (** Requires {b "password" param}, otherwise skipped.*) 4 | 5 | (**Name of the strategy.*) 6 | val name : string 7 | 8 | (**[MODEL] contains requirements for user model in order to use the strategy*) 9 | module type MODEL = sig 10 | type t 11 | 12 | (**[encrypted_password] is a string of hashed password, against which a given password will be verified. Argon2 is used for verification.*) 13 | val encrypted_password : t -> string option 14 | end 15 | 16 | (**[Make] creates a strategy for a provided model.*) 17 | module Make : 18 | functor (M : MODEL) -> 19 | sig 20 | type entity = M.t 21 | 22 | (**[call] is a main function of a strategy, which authenticates the user by "password" param. 23 | The param is verified against a hashed password with Argon2.*) 24 | val call : 25 | Dream.request -> 26 | entity -> entity FPauth_core.Static.StratResult.t Lwt.t 27 | 28 | (**This strategy has no routes and returns [Dream.no_route]*) 29 | val routes : Dream.route 30 | 31 | (**See {!Password.name}*) 32 | val name : string 33 | end 34 | -------------------------------------------------------------------------------- /test/core/authenticator.ml: -------------------------------------------------------------------------------- 1 | (*Tests for Authenticator*) 2 | 3 | open Base 4 | open Lwt 5 | open Lwt.Syntax 6 | open Setup 7 | open FPauth_core.Static 8 | 9 | module A = Auth.Authenticator 10 | 11 | let strategy : Auth.Authenticator.strategy = (module Strategy) 12 | 13 | let wrong_strat : Auth.Authenticator.strategy = (module ChangeNameStrat) 14 | 15 | let fake_extractor lst _ = Params.of_assoc lst |> Lwt.return 16 | 17 | let test_middlewares params handler = Dream.memory_sessions 18 | @@ Auth.Session_manager.auth_setup 19 | @@ Params.set_params ~extractor:(fake_extractor params) 20 | handler 21 | 22 | let respond request = function 23 | |AuthResult.Authenticated -> 24 | let user = Dream.field request Auth.Variables.current_user |> Option.value ~default:user_none in 25 | "name : "^(Entity.name user) |> Dream.respond 26 | | Rescue -> 27 | let error = Dream.field request Auth.Variables.auth_error |>Option.value ~default:(Error.of_string "no error") in 28 | "error : "^(Error.to_string_hum error) |> Dream.respond 29 | | Redirect response -> Lwt_main.run response |> Dream.status |> Dream.status_to_string |> Dream.respond 30 | 31 | let authenticate_test params expected message = 32 | let req = Dream.request "" in 33 | let handler requset = A.authenticate [strategy] requset >>= respond requset in 34 | let response = Dream.test (test_middlewares params handler) req in 35 | let expected = expected in 36 | Dream.body response 37 | |> Lwt_main.run 38 | |> Alcotest.(check string) message expected 39 | 40 | let tests = "FPauth.Authenticator: ", [ 41 | "Normal auth" -: begin fun () -> 42 | let params = [("name", "test"); ("pass", "test")] 43 | and expected = "name : test" 44 | and message = "Authenticated test" 45 | in authenticate_test params expected message 46 | end; 47 | 48 | "Failed identification" -: begin fun () -> 49 | let params = [("name", "test1"); ("pass", "test")] 50 | and expected = "error : Wrong name" 51 | and message = "Failed to identificate user test1" 52 | in authenticate_test params expected message 53 | end; 54 | 55 | "Failed authentication" -: begin fun () -> 56 | let params = [("name", "test"); ("pass", "test1")] 57 | and expected = "error : Wrong pass" 58 | and message = "Failed to authenticate with wrong pass" 59 | in authenticate_test params expected message 60 | end; 61 | 62 | "Skipping strategy" -: begin fun () -> 63 | let params = [("name", "test")] 64 | and expected = "error : End of strategy list" 65 | and message = "Skipped all strategies" 66 | in authenticate_test params expected message 67 | end; 68 | 69 | "Redirect from strategy" -: begin fun () -> 70 | let params = [("name", "test"); ("pass", "redirect")] 71 | and expected = `See_Other |> Dream.status_to_string 72 | and message = "Redirected" 73 | in authenticate_test params expected message 74 | end; 75 | 76 | "Filtering non-applicable strat" -: begin fun () -> 77 | let req = Dream.request "" in 78 | let handler requset = A.authenticate [wrong_strat] requset >>= respond requset in 79 | let response = Dream.test (test_middlewares [("name", "test"); ("pass", "test")] handler) req in 80 | let expected = "error : End of strategy list" in 81 | Dream.body response 82 | |> Lwt_main.run 83 | |> Alcotest.(check string) "Filtered all strategies" expected 84 | end; 85 | 86 | "Logout" -: begin fun () -> 87 | let req = Dream.request "" in 88 | let put_session value inner_handler requset = 89 | let* () = Dream.set_session_field requset "auth" value in 90 | inner_handler requset in 91 | let test_handler request = 92 | let auth req = Dream.field req Auth.Variables.authenticated |> Option.value ~default:false |> Bool.to_string 93 | in 94 | let* () = A.logout request in 95 | Dream.respond ("auth : "^auth request) in 96 | let response = Dream.test (Dream.memory_sessions 97 | @@ put_session (Entity.serialize user) 98 | @@ Auth.Session_manager.auth_setup 99 | @@ test_handler) req in 100 | let expected = "auth : false" in 101 | Dream.body response 102 | |> Lwt_main.run 103 | |> Alcotest.(check string) "Authentication reset" expected 104 | end; 105 | ] -------------------------------------------------------------------------------- /test/core/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name unit) 3 | (package FPauth-core) 4 | (libraries 5 | alcotest 6 | dream 7 | lwt 8 | lwt.unix 9 | FPauth-core 10 | base 11 | )) 12 | 13 | ; (rule 14 | ; (alias runtest) 15 | ; (action (run %{exe:unit.exe}))) -------------------------------------------------------------------------------- /test/core/router.ml: -------------------------------------------------------------------------------- 1 | (*Tests for Router*) 2 | 3 | open Base 4 | open Lwt.Syntax 5 | open Setup 6 | open FPauth_core 7 | 8 | module R = Auth.Router 9 | 10 | let strategy : Auth.Authenticator.strategy = (module Strategy) 11 | 12 | let fake_extractor lst _ = Static.Params.of_assoc lst |> Lwt.return 13 | 14 | module Responses = struct 15 | open Dream 16 | let login_successful request = 17 | let user = Option.value_exn (field request Auth.Variables.current_user) in 18 | respond ("user : "^ Entity.name user) 19 | 20 | let login_error request = 21 | let err = field request (Auth.Variables.auth_error) |> Option.value ~default:(Error.of_string "Unknown error") in 22 | respond ("error : "^ Error.to_string_hum err) 23 | 24 | let logout request = 25 | match field request Auth.Variables.authenticated with 26 | | None -> respond ("error : No local") 27 | | Some auth -> respond ("auth : "^( auth |> Bool.to_string)) 28 | end 29 | 30 | let test_middlewares params = Dream.memory_sessions 31 | @@ Auth.Session_manager.auth_setup 32 | @@ Dream.router [ 33 | R.call [strategy] ~responses:(module Responses) ~extractor:(fake_extractor params) 34 | ] 35 | 36 | let tests = "FPauth.Router: ", [ 37 | "Login successful" -: begin fun () -> 38 | let req = Dream.request ~target:"/auth" ~method_:`POST "" in 39 | let response = Dream.test (test_middlewares [("name", "test"); ("pass", "test")]) req in 40 | let expected = "user : test" in 41 | Dream.body response 42 | |> Lwt_main.run 43 | |> Alcotest.(check string) "Used auth route for successful authentication" expected 44 | end; 45 | 46 | "Login unsuccessful" -: begin fun () -> 47 | let req = Dream.request ~target:"/auth" ~method_:`POST "" in 48 | let response = Dream.test (test_middlewares [("name", "test1"); ("pass", "test")]) req in 49 | let expected = "error : Wrong name" in 50 | Dream.body response 51 | |> Lwt_main.run 52 | |> Alcotest.(check string) "Used auth route for unsuccessful authentication" expected 53 | end; 54 | 55 | "Login redirected" -: begin fun () -> 56 | let req = Dream.request ~target:"/auth" ~method_:`POST "" in 57 | let response = Dream.test (test_middlewares [("name", "test"); ("pass", "redirect")]) req in 58 | let expected = `See_Other |> Dream.status_to_string in 59 | Dream.status response 60 | |> Dream.status_to_string 61 | |> Alcotest.(check string) "Used auth route for successful authentication" expected 62 | end; 63 | 64 | "Logout" -: begin fun () -> 65 | let req = Dream.request ~target:"/logout" "" in 66 | let put_session value inner_handler requset = 67 | let* () = Dream.set_session_field requset "auth" value in 68 | inner_handler requset in 69 | let response = Dream.test (Dream.memory_sessions 70 | @@ put_session (Entity.serialize user) 71 | @@ Auth.Session_manager.auth_setup 72 | @@ Dream.router [R.call [strategy] ~responses:(module Responses) ~extractor:(fake_extractor [])]) 73 | req in 74 | let expected = "auth : false" in 75 | Dream.body response 76 | |> Lwt_main.run 77 | |> Alcotest.(check string) "Authentication reset" expected 78 | end; 79 | ] -------------------------------------------------------------------------------- /test/core/session_manager.ml: -------------------------------------------------------------------------------- 1 | (*Tests for SessionManager*) 2 | 3 | open Base 4 | open Lwt.Syntax 5 | open Setup 6 | 7 | module SM = Auth.Session_manager 8 | 9 | let test_handler request = 10 | let auth = Dream.field request Auth.Variables.authenticated |> Option.value ~default:false |> Bool.to_string 11 | and user = Dream.field request Auth.Variables.current_user |> Option.value ~default:user_none |> Entity.name 12 | in 13 | Dream.respond ("auth : "^auth^"; user : "^user) 14 | 15 | let put_session value inner_handler requset = 16 | let* () = Dream.set_session_field requset "auth" value in 17 | inner_handler requset 18 | 19 | let tests = "FPauth.SessionManager: ", [ 20 | "empty session" -: begin fun () -> 21 | let req = Dream.request "" in 22 | let response = Dream.test (Dream.memory_sessions @@ SM.auth_setup test_handler) req in 23 | let expected = "auth : false; user : none" in 24 | Dream.body response |> Lwt_main.run |> Alcotest.(check string) "OK no auth" expected 25 | end; 26 | 27 | "authenticated session" -: begin fun () -> 28 | let req = Dream.request "" in 29 | let response = Dream.test (Dream.memory_sessions 30 | @@ put_session (Entity.serialize user) 31 | @@ SM.auth_setup 32 | @@ test_handler) req in 33 | let expected = "auth : true; user : test" in 34 | Dream.body response |> Lwt_main.run |> Alcotest.(check string) "OK auth test user" expected 35 | end; 36 | 37 | "auth field empty" -: begin fun () -> 38 | let req = Dream.request "" in 39 | let response = Dream.test (Dream.memory_sessions 40 | @@ put_session "" 41 | @@ SM.auth_setup 42 | @@ test_handler) req in 43 | let expected = `Unauthorized |> Dream.status_to_string in 44 | Dream.status response |> Dream.status_to_string |> Alcotest.(check string) "Error unauthorized" expected 45 | end; 46 | 47 | "auth deserialization error" -: begin fun () -> 48 | let req = Dream.request "" in 49 | let response = Dream.test (Dream.memory_sessions 50 | @@ put_session (Entity.serialize user_none) 51 | @@ SM.auth_setup 52 | @@ test_handler) req in 53 | let expected = `Unauthorized |> Dream.status_to_string in 54 | Dream.status response |> Dream.status_to_string |> Alcotest.(check string) "Error unauthorized" expected 55 | end; 56 | ] -------------------------------------------------------------------------------- /test/core/setup.ml: -------------------------------------------------------------------------------- 1 | (*Setting up testing env*) 2 | open Base 3 | 4 | (* operator for making quick tests *) 5 | let (-:) key f = Alcotest.test_case key `Quick f 6 | 7 | (*Mock of a model*) 8 | module Entity = struct 9 | type t = {name:string} 10 | 11 | let serialize ent = ent.name 12 | 13 | let deserialize str = 14 | if String.equal str "test" then 15 | Result.Ok {name=str} 16 | else 17 | Result.Error (Error.of_string "Wrong name!") 18 | 19 | let identificate request = 20 | match FPauth_core.Static.Params.get_param_req "name" request with 21 | | None -> Lwt.return_error (Error.of_string "No param \'name\' in request") 22 | | Some "test1" -> Lwt.return_error (Error.of_string "Wrong name") 23 | | Some name -> Lwt.return_ok {name} 24 | 25 | let applicable_strats _ = ["Test"] 26 | 27 | let name ent = ent.name 28 | end 29 | 30 | let user_none : Entity.t = {name = "none"} 31 | 32 | let user : Entity.t = {name = "test"} 33 | 34 | module Auth = FPauth_core.Make_Auth (Entity) 35 | 36 | module Strategy = struct 37 | open FPauth_core.Static 38 | 39 | type entity = Entity.t 40 | 41 | let call request user = 42 | let result = 43 | match Params.get_param_req "pass" request with 44 | | None -> StratResult.Next 45 | | Some "redirect" -> StratResult.Redirect (Dream.redirect request "/") 46 | | Some pass -> 47 | if String.equal ("test") (pass) then 48 | StratResult.Authenticated user 49 | else 50 | StratResult.Rescue (Error.of_string "Wrong pass") 51 | in 52 | Lwt.return result 53 | 54 | let routes = Dream.no_route 55 | 56 | let name = "Test" 57 | end 58 | 59 | module ChangeNameStrat = struct 60 | type entity = Strategy.entity 61 | 62 | let call = Strategy.call 63 | 64 | let routes = Strategy.routes 65 | 66 | let name = "Not test" 67 | end 68 | -------------------------------------------------------------------------------- /test/core/static.ml: -------------------------------------------------------------------------------- 1 | (*Testing Static*) 2 | open FPauth_core.Static 3 | open Base 4 | open Setup 5 | 6 | let stratresult_pp pp_val formatter s = 7 | let open Fmt in 8 | match s with 9 | | StratResult.Authenticated smth -> pf formatter "Authenticated: "; pp_val formatter smth 10 | | Rescue err -> pf formatter "Rescue: "; Error.pp formatter err 11 | | Next -> pf formatter "Next" 12 | | Redirect _ -> pf formatter "Redirect" 13 | 14 | let stratresult_eq eq a b = 15 | match a, b with 16 | | StratResult.Authenticated a_v, StratResult.Authenticated b_v -> eq a_v b_v 17 | | Rescue a_err, Rescue b_err -> Error.equal a_err b_err 18 | | Next, Next -> true 19 | | Redirect a_prom, Redirect b_prom -> 20 | let a_resp, b_resp = Lwt_main.run (Lwt.both a_prom b_prom) in 21 | let pair_equal eq a b = eq (fst a) (fst b) && eq (snd a) (snd b) in 22 | List.equal (pair_equal String.equal) (Dream.all_headers a_resp) (Dream.all_headers b_resp) 23 | | _ -> false 24 | 25 | let stratresult_string = 26 | Alcotest.testable (stratresult_pp String.pp) (stratresult_eq String.equal) 27 | 28 | let strat_result = "FPauth.Static: StratResult", [ 29 | "bind_authenticated" -: begin fun () -> 30 | let auth = StratResult.Authenticated "first" in 31 | let res_func prev = StratResult.Authenticated (prev^" correct") in 32 | let expected = StratResult.Authenticated "first correct" 33 | in 34 | StratResult.bind auth res_func |> Alcotest.(check stratresult_string) "authenticated" expected 35 | end; 36 | 37 | "bind_rescue" -: begin fun () -> 38 | let auth = StratResult.Rescue (Error.of_string "test_error") in 39 | let res_func prev = StratResult.Authenticated (prev^" correct") in 40 | let expected = StratResult.Rescue (Error.of_string "test_error") 41 | in 42 | StratResult.bind auth res_func |> Alcotest.(check stratresult_string) "rescue" expected 43 | end; 44 | 45 | "bind_next" -: begin fun () -> 46 | let auth = StratResult.Next in 47 | let res_func prev = StratResult.Authenticated (prev^" correct") in 48 | let expected = StratResult.Next 49 | in 50 | StratResult.bind auth res_func |> Alcotest.(check stratresult_string) "next" expected 51 | end; 52 | 53 | "bind_redirect" -: begin fun () -> 54 | let auth = StratResult.Redirect (Dream.redirect (Dream.request "") "/test_url") in 55 | let res_func prev = StratResult.Authenticated (prev^" correct") in 56 | let expected = StratResult.Redirect (Dream.redirect (Dream.request "") "/test_url") 57 | in 58 | StratResult.bind auth res_func |> Alcotest.(check stratresult_string) "redirect" expected 59 | end 60 | ] 61 | 62 | let params = "FPauth.Static: Params", [ 63 | "params in field" -: begin fun () -> 64 | let req = Dream.request "" in 65 | let fake_extractor _ = Params.of_assoc [("key", "value")] |> Lwt.return in 66 | let handler request = 67 | let param = Params.get_param_req "key" request in 68 | Dream.respond ~headers:[("key", Option.value param ~default:"")] "" 69 | in 70 | let response = Dream.test (Params.set_params ~extractor:(fake_extractor) handler) req in 71 | let header = Dream.headers response "key" in 72 | let expected = ["value"] in 73 | header |> Alcotest.(check (list string)) "params in field" expected 74 | end; 75 | 76 | "no param found" -: begin fun () -> 77 | let req = Dream.request "" in 78 | let handler request = 79 | let param = Params.get_param_req "key" request in 80 | Dream.respond ~headers:[("key", Option.value param ~default:"")] "" 81 | in 82 | let response = Dream.test handler req in 83 | let header = Dream.headers response "key" in 84 | let expected = [""] in 85 | header |> Alcotest.(check (list string)) "no param in field" expected 86 | end; 87 | 88 | "get param exn" -: begin fun () -> 89 | let params = Params.of_assoc [("key", "value")] in 90 | let expected = "value" in 91 | params |> Params.get_param_exn "key" |> Alcotest.(check string) "get_param_exn" expected 92 | end; 93 | 94 | "query param extractor" -: begin fun () -> 95 | let req = Dream.request ~target:"/?key=value" "" in 96 | let params = Params.extract_query req |> Lwt_main.run in 97 | let expected = Some "value" in 98 | params |> Params.get_param "key" |> Alcotest.(check (option string)) "extract_query" expected 99 | end; 100 | 101 | "json param extractor" -: begin fun () -> 102 | let req = Dream.request ~headers:[("Content-Type", "application/json")] "{\"key\" : \"value\"}" in 103 | let params = Params.extract_json req |> Lwt_main.run in 104 | let expected = Some "value" in 105 | params |> Params.get_param "key" |> Alcotest.(check (option string)) "extract_json" expected 106 | end; 107 | 108 | "json param extractor with unsupported content" -: begin fun () -> 109 | let req = Dream.request "" in 110 | let params = Params.extract_json req |> Lwt_main.run in 111 | let expected = None in 112 | params |> Params.get_param "key" |> Alcotest.(check (option string)) "extract_json" expected 113 | end; 114 | 115 | "form param extractor" -: begin fun () -> 116 | let req = Dream.request ~headers:[("Content-Type", "application/x-www-form-urlencoded")] "key=value" in 117 | let params = Params.extract_form ~csrf:false req |> Lwt_main.run in 118 | let expected = Some "value" in 119 | params |> Params.get_param "key" |> Alcotest.(check (option string)) "extracted successfully" expected 120 | end; 121 | 122 | "form param extractor with unsupported content" -: begin fun () -> 123 | let req = Dream.request "key=value" in 124 | let params = Params.extract_form ~csrf:false req |> Lwt_main.run in 125 | let expected = None in 126 | params |> Params.get_param "key" |> Alcotest.(check (option string)) "not extracted" expected 127 | end; 128 | 129 | "form param extractor if Dream.form not Ok" -: begin fun () -> 130 | let req = Dream.request ~headers:[("Content-Type", "application/x-www-form-urlencoded")] "key=value" in 131 | let params = Params.extract_form req |> Lwt_main.run in 132 | let expected = None in 133 | params |> Params.get_param "key" |> Alcotest.(check (option string)) "not extracted" expected 134 | end; 135 | ] -------------------------------------------------------------------------------- /test/core/unit.ml: -------------------------------------------------------------------------------- 1 | (*Main test executable*) 2 | 3 | Alcotest.run "FPauth-core" [Static.strat_result; 4 | Static.params; 5 | Session_manager.tests; 6 | Authenticator.tests; 7 | Router.tests] -------------------------------------------------------------------------------- /test/strategies/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name unit) 3 | (package FPauth-strategies) 4 | (libraries 5 | alcotest 6 | dream 7 | lwt 8 | lwt.unix 9 | FPauth-core 10 | FPauth-strategies 11 | base 12 | twostep 13 | ) 14 | (preprocess 15 | (pps lwt_ppx))) 16 | 17 | ; (rule 18 | ; (alias runtest) 19 | ; (action (run %{exe:unit.exe}))) -------------------------------------------------------------------------------- /test/strategies/password.ml: -------------------------------------------------------------------------------- 1 | (*Testing Password strategy*) 2 | open Base 3 | open Setup 4 | 5 | module Entity = EntityPassword 6 | 7 | module Password = FPauth_strategies.Password 8 | 9 | module Strategy = Password.Make (Entity) 10 | 11 | let user : Entity.t = {name = "test"} 12 | 13 | let user_none : Entity.t = {name = "none"} 14 | 15 | let user_rand : Entity.t = {name= "rand"} 16 | 17 | module Auth = FPauth_core.Make_Auth(Entity) 18 | 19 | let fake_extractor lst _ = FPauth_core.Static.Params.of_assoc lst |> Lwt.return 20 | 21 | let test_middlewares params handler = Dream.memory_sessions 22 | @@ Auth.Session_manager.auth_setup 23 | @@ FPauth_core.Static.Params.set_params ~extractor:(fake_extractor params) 24 | handler 25 | 26 | let test_handler user request = 27 | match%lwt Strategy.call request user with 28 | |Authenticated usr -> Dream.respond ("name : "^ Entity.name usr) 29 | |Rescue err -> Dream.respond ("error : "^ Error.to_string_hum err) 30 | |Next -> Dream.respond "next" 31 | |Redirect resp -> resp 32 | 33 | let tests = "Password strategy", [ 34 | "Normal call" -: begin fun () -> 35 | let req = Dream.request "" in 36 | let response = Dream.test (test_middlewares [("password", "12345678")] (test_handler user)) req 37 | and expected = "name : test" in 38 | Dream.body response 39 | |> Lwt_main.run 40 | |> Alcotest.(check string) "Correct password" expected 41 | end; 42 | 43 | "No password in params" -: begin fun () -> 44 | let req = Dream.request "" in 45 | let response = Dream.test (test_middlewares [] (test_handler user)) req 46 | and expected = "next" in 47 | Dream.body response 48 | |> Lwt_main.run 49 | |> Alcotest.(check string) "Skipped the strategy" expected 50 | end; 51 | 52 | "No encrypted password" -: begin fun () -> 53 | let req = Dream.request "" in 54 | let response = Dream.test (test_middlewares [("password", "12345678")] (test_handler user_none)) req 55 | and expected = "error : No encrypted password for the user" in 56 | Dream.body response 57 | |> Lwt_main.run 58 | |> Alcotest.(check string) "Can't get encrypted password" expected 59 | end; 60 | 61 | "Wrong password hash" -: begin fun () -> 62 | let req = Dream.request "" in 63 | let response = Dream.test (test_middlewares [("password", "12345678")] (test_handler user_rand)) req 64 | and expected = "error : Decoding failed" in 65 | Dream.body response 66 | |> Lwt_main.run 67 | |> Alcotest.(check string) "Argon2 error" expected 68 | end; 69 | 70 | "Wrong password recieved" -: begin fun () -> 71 | let req = Dream.request "" in 72 | let response = Dream.test (test_middlewares [("password", "11111111")] (test_handler user)) req 73 | and expected = "error : Incorrect password!" in 74 | Dream.body response 75 | |> Lwt_main.run 76 | |> Alcotest.(check string) "Wrong password" expected 77 | end; 78 | ] -------------------------------------------------------------------------------- /test/strategies/setup.ml: -------------------------------------------------------------------------------- 1 | (*Setting up testing env*) 2 | open Base 3 | 4 | (* operator for making quick tests *) 5 | let (-:) key f = Alcotest.test_case key `Quick f 6 | 7 | (* This module helps with password hashing *) 8 | module Encryptor = struct 9 | open Base 10 | 11 | type params = { 12 | time_cost: int; 13 | memory_cost_kiB: int; 14 | parallelism: int; 15 | hash_len: int; 16 | salt_len: int; 17 | } 18 | 19 | (* Recommended parameters 20 | https://argon2-cffi.readthedocs.io/en/stable/api.html#argon2.PasswordHasher *) 21 | let recommend_params = { 22 | time_cost = 2; 23 | memory_cost_kiB = 100 * 1024; (*100MiB*) 24 | parallelism = 8; 25 | hash_len = 16; 26 | salt_len = 16; 27 | } 28 | 29 | let hash ?(params=recommend_params) password = 30 | let { 31 | time_cost; 32 | memory_cost_kiB; 33 | parallelism; 34 | hash_len; 35 | salt_len; 36 | } = params in 37 | 38 | let salt = Dream.random(16) in 39 | 40 | let encoded_len = 41 | Argon2.encoded_len 42 | ~t_cost:time_cost 43 | ~m_cost:memory_cost_kiB 44 | ~parallelism 45 | ~salt_len 46 | ~hash_len 47 | ~kind:Argon2.ID 48 | in 49 | let encoded = 50 | Argon2.ID.hash_encoded 51 | ~t_cost:time_cost 52 | ~m_cost:memory_cost_kiB 53 | ~parallelism 54 | ~pwd:password 55 | ~salt 56 | ~hash_len 57 | ~encoded_len 58 | in match encoded with 59 | | Ok enc -> Ok (Argon2.ID.encoded_to_string enc) 60 | | Error e -> Error e 61 | end 62 | 63 | 64 | (*Mock of a model for Password strat*) 65 | module EntityPassword = struct 66 | type t = {name:string} 67 | 68 | let serialize ent = ent.name 69 | 70 | let deserialize str = 71 | if String.equal str "test" then 72 | Result.Ok {name=str} 73 | else 74 | Result.Error (Error.of_string "Wrong name!") 75 | 76 | let identificate request = 77 | match FPauth_core.Static.Params.get_param_req "name" request with 78 | | None -> Lwt.return_error (Error.of_string "No param \'name\' in request") 79 | | Some "test1" -> Lwt.return_error (Error.of_string "Wrong name") 80 | | Some name -> Lwt.return_ok {name} 81 | 82 | let applicable_strats _ = [FPauth_strategies.Password.name] 83 | 84 | let name ent = ent.name 85 | 86 | let encrypted_password user = 87 | match name user with 88 | | "none" -> None 89 | | "test" -> begin 90 | match Encryptor.hash "12345678" with 91 | |Ok str -> Some str 92 | |Error _ -> None 93 | end; 94 | | _ -> Some "randomstring" 95 | end 96 | 97 | (*Mock of a model for OTP strat*) 98 | module EntityOTP = struct 99 | type t = {name:string} 100 | 101 | let serialize ent = ent.name 102 | 103 | let deserialize str = Result.Ok {name=str} 104 | 105 | let identificate request = 106 | match FPauth_core.Static.Params.get_param_req "name" request with 107 | | None -> Lwt.return_error (Error.of_string "No param \'name\' in request") 108 | | Some "test1" -> Lwt.return_error (Error.of_string "Wrong name") 109 | | Some name -> Lwt.return_ok {name} 110 | 111 | let applicable_strats _ = [FPauth_strategies.TOTP.name] 112 | 113 | let name ent = ent.name 114 | 115 | let otp_secret _ = "AAAA BBBB CCCC DDDD" 116 | 117 | let otp_enabled user = 118 | match name user with 119 | | "test" -> true 120 | | _ -> false 121 | 122 | let set_otp_secret _ user secret = 123 | {name=(user.name ^ secret)} |> Lwt.return 124 | 125 | let set_otp_enabled _ user enabled = 126 | {name=(user.name ^ (Bool.to_string enabled))} |> Lwt.return 127 | end 128 | -------------------------------------------------------------------------------- /test/strategies/totp.ml: -------------------------------------------------------------------------------- 1 | (*Testing OTP strategy*) 2 | open Base 3 | open Setup 4 | 5 | module Entity = EntityOTP 6 | 7 | module Auth = FPauth_core.Make_Auth(Entity) 8 | 9 | module OtpResponses = struct 10 | let response_error _ err = 11 | Dream.respond ("error : "^Error.to_string_hum err) 12 | 13 | let response_secret _ _ = 14 | Dream.respond ("secret : generated") 15 | 16 | let response_enabled _ = 17 | Dream.respond ("TOTP enabled : true") 18 | end 19 | 20 | module Otp = FPauth_strategies.TOTP 21 | 22 | module Strategy = Otp.Make (OtpResponses) (Entity) (Auth.Variables) 23 | 24 | let strategy : Auth.Authenticator.strategy = (module Strategy) 25 | 26 | let user : Entity.t = {name = "test"} 27 | 28 | let user_none : Entity.t = {name = "none"} 29 | 30 | module Responses = struct 31 | open Dream 32 | let login_successful request = 33 | let user = Option.value_exn (field request Auth.Variables.current_user) in 34 | respond ("user : "^ Entity.name user) 35 | 36 | let login_error request = 37 | let err = field request (Auth.Variables.auth_error) |> Option.value ~default:(Error.of_string "Unknown error") in 38 | respond ("error : "^ Error.to_string_hum err) 39 | 40 | let logout request = 41 | match field request Auth.Variables.authenticated with 42 | | None -> respond ("error : No local") 43 | | Some auth -> respond ("auth : "^( auth |> Bool.to_string)) 44 | end 45 | 46 | let fake_extractor lst _ = FPauth_core.Static.Params.of_assoc lst |> Lwt.return 47 | 48 | let test_middlewares_call params handler = Dream.memory_sessions 49 | @@ Auth.Session_manager.auth_setup 50 | @@ FPauth_core.Static.Params.set_params ~extractor:(fake_extractor params) 51 | handler 52 | 53 | let put_session usr inner_handler requset = 54 | let%lwt () = Dream.set_session_field requset "auth" (Entity.serialize usr) in 55 | inner_handler requset 56 | let test_middlewares_handlers usr params = Dream.memory_sessions 57 | @@ put_session usr 58 | @@ Auth.Session_manager.auth_setup 59 | @@ Dream.router [ 60 | Auth.Router.call [strategy] ~responses:(module Responses) ~extractor:(fake_extractor params) 61 | ] 62 | let test_middlewares_handlers_empty params = Dream.memory_sessions 63 | @@ Auth.Session_manager.auth_setup 64 | @@ Dream.router [ 65 | Auth.Router.call [strategy] ~responses:(module Responses) ~extractor:(fake_extractor params) 66 | ] 67 | 68 | let test_handler user request = 69 | match%lwt Strategy.call request user with 70 | |Authenticated usr -> Dream.respond ("name : "^ Entity.name usr) 71 | |Rescue err -> Dream.respond ("error : "^ Error.to_string_hum err) 72 | |Next -> Dream.respond "next" 73 | |Redirect resp -> resp 74 | 75 | let tests = "OTP strategy", [ 76 | "Normal call" -: begin fun () -> 77 | let req = Dream.request "" in 78 | let otp_code = Twostep.TOTP.code ~secret:(Entity.otp_secret ()) () in 79 | let response = Dream.test (test_middlewares_call [("totp_code", otp_code)] (test_handler user)) req 80 | and expected = "name : test" in 81 | Dream.body response 82 | |> Lwt_main.run 83 | |> Alcotest.(check string) "User authenticated" expected 84 | end; 85 | 86 | "OTP disabled" -: begin fun () -> 87 | let req = Dream.request "" in 88 | let otp_code = Twostep.TOTP.code ~secret:(Entity.otp_secret ()) () in 89 | let response = Dream.test (test_middlewares_call [("totp_code", otp_code)] (test_handler user_none)) req 90 | and expected = "next" in 91 | Dream.body response 92 | |> Lwt_main.run 93 | |> Alcotest.(check string) "Skipped strategy" expected 94 | end; 95 | 96 | "No otp code" -: begin fun () -> 97 | let req = Dream.request "" in 98 | let response = Dream.test (test_middlewares_call [] (test_handler user)) req 99 | and expected = "next" in 100 | Dream.body response 101 | |> Lwt_main.run 102 | |> Alcotest.(check string) "Skipped strategy" expected 103 | end; 104 | 105 | "Incorrect otp" -: begin fun () -> 106 | let req = Dream.request "" in 107 | let otp_code = "lalala" in 108 | let response = Dream.test (test_middlewares_call [("totp_code", otp_code)] (test_handler user)) req 109 | and expected = "error : One-time password is incorrect!" in 110 | Dream.body response 111 | |> Lwt_main.run 112 | |> Alcotest.(check string) "Error raised" expected 113 | end; 114 | 115 | "Auth before otp setup" -: begin fun () -> 116 | let req = Dream.request ~target:"/totp/generate_secret" ~method_:`GET "" in 117 | let response = Dream.test (test_middlewares_handlers_empty []) req 118 | and expected = "error : User should be authenticated first" in 119 | Dream.body response 120 | |> Lwt_main.run 121 | |> Alcotest.(check string) "Error raised" expected 122 | end; 123 | 124 | "Otp generate secret" -: begin fun () -> 125 | let req = Dream.request ~target:"/totp/generate_secret" ~method_:`GET "" in 126 | let response = Dream.test (test_middlewares_handlers user_none []) req 127 | and expected = "secret : generated" in 128 | Dream.body response 129 | |> Lwt_main.run 130 | |> Alcotest.(check string) "OTP secret presented" expected 131 | end; 132 | 133 | "Otp enabled for secret gen" -: begin fun () -> 134 | let req = Dream.request ~target:"/totp/generate_secret" ~method_:`GET "" in 135 | let response = Dream.test (test_middlewares_handlers user []) req 136 | and expected = "error : OTP is already enabled" in 137 | Dream.body response 138 | |> Lwt_main.run 139 | |> Alcotest.(check string) "OTP is already enabled" expected 140 | end; 141 | 142 | "Auth before otp setup finish" -: begin fun () -> 143 | let req = Dream.request ~target:"/totp/finish_setup" ~method_:`POST "" in 144 | let response = Dream.test (test_middlewares_handlers_empty []) req 145 | and expected = "error : User should be authenticated first" in 146 | Dream.body response 147 | |> Lwt_main.run 148 | |> Alcotest.(check string) "Error raised" expected 149 | end; 150 | 151 | "Otp enabled for setup finish" -: begin fun () -> 152 | let req = Dream.request ~target:"/totp/finish_setup" ~method_:`POST "" in 153 | let response = Dream.test (test_middlewares_handlers user []) req 154 | and expected = "error : OTP is already enabled" in 155 | Dream.body response 156 | |> Lwt_main.run 157 | |> Alcotest.(check string) "OTP is already enabled" expected 158 | end; 159 | 160 | "Correct otp to finish" -: begin fun () -> 161 | let req = Dream.request ~target:"/totp/finish_setup" ~method_:`POST "" in 162 | let otp_code = Twostep.TOTP.code ~secret:(Entity.otp_secret ()) () in 163 | let response = Dream.test (test_middlewares_handlers user_none [("totp_code", otp_code)]) req 164 | and expected = "TOTP enabled : true" in 165 | Dream.body response 166 | |> Lwt_main.run 167 | |> Alcotest.(check string) "Setup finished" expected 168 | end; 169 | 170 | "Inorrect otp to finish" -: begin fun () -> 171 | let req = Dream.request ~target:"/totp/finish_setup" ~method_:`POST "" in 172 | let otp_code = "lololo" in 173 | let response = Dream.test (test_middlewares_handlers user_none [("totp_code", otp_code)]) req 174 | and expected = "error : One-time password is incorrect!" in 175 | Dream.body response 176 | |> Lwt_main.run 177 | |> Alcotest.(check string) "Setup finished" expected 178 | end; 179 | 180 | "No otp to finish" -: begin fun () -> 181 | let req = Dream.request ~target:"/totp/finish_setup" ~method_:`POST "" in 182 | let response = Dream.test (test_middlewares_handlers user_none []) req 183 | and expected = "error : \'TOTP code\' param not found in request" in 184 | Dream.body response 185 | |> Lwt_main.run 186 | |> Alcotest.(check string) "Error raised" expected 187 | end; 188 | ] 189 | 190 | module Json_strat = Otp.Make (Otp.JSON_Responses) (Entity) (Auth.Variables) 191 | 192 | let json_strat : Auth.Authenticator.strategy = (module Json_strat) 193 | 194 | let json_test_middlewares usr params = Dream.memory_sessions 195 | @@ put_session usr 196 | @@ Auth.Session_manager.auth_setup 197 | @@ Dream.router [ 198 | Auth.Router.call [json_strat] ~responses:(module Responses) ~extractor:(fake_extractor params) 199 | ] 200 | 201 | let json_tests = "OTP JSON responses tests", [ 202 | "response_error" -: begin fun () -> 203 | let req = Dream.request ~target:"/totp/finish_setup" ~method_:`POST "" in 204 | let response = Dream.test (json_test_middlewares user []) req 205 | and expected = "application/json" in 206 | Dream.header response "Content-Type" 207 | |> Option.value ~default:"" 208 | |> Alcotest.(check string) "JSON recieved" expected 209 | end; 210 | 211 | "response_secret" -: begin fun () -> 212 | let req = Dream.request ~target:"/totp/generate_secret" ~method_:`GET "" in 213 | let response = Dream.test (json_test_middlewares user_none []) req 214 | and expected = "application/json" in 215 | Dream.header response "Content-Type" 216 | |> Option.value ~default:"" 217 | |> Alcotest.(check string) "JSON recieved" expected 218 | end; 219 | 220 | "response_enabled" -: begin fun () -> 221 | let req = Dream.request ~target:"/totp/finish_setup" ~method_:`POST "" in 222 | let otp_code = Twostep.TOTP.code ~secret:(Entity.otp_secret ()) () in 223 | let response = Dream.test (json_test_middlewares user_none [("totp_code", otp_code)]) req 224 | and expected = "application/json" in 225 | Dream.header response "Content-Type" 226 | |> Option.value ~default:"" 227 | |> Alcotest.(check string) "JSON recieved" expected 228 | end; 229 | ] 230 | 231 | module HTML_responses = (val Otp.make_html_responses ~app_name:"Test" ()) 232 | 233 | module Html_strat = Otp.Make (HTML_responses) (Entity) (Auth.Variables) 234 | 235 | let html_strat : Auth.Authenticator.strategy = (module Html_strat) 236 | 237 | let html_test_middlewares usr params = Dream.memory_sessions 238 | @@ put_session usr 239 | @@ Auth.Session_manager.auth_setup 240 | @@ Dream.router [ 241 | Auth.Router.call [html_strat] ~responses:(module Responses) ~extractor:(fake_extractor params)] 242 | 243 | let html_tests = "OTP HTML responses test", [ 244 | "response_error" -: begin fun () -> 245 | let req = Dream.request ~target:"/totp/finish_setup" ~method_:`POST "" in 246 | let response = Dream.test (html_test_middlewares user []) req 247 | and expected = "text/html; charset=utf-8" in 248 | Dream.header response "Content-Type" 249 | |> Option.value ~default:"" 250 | |> Alcotest.(check string) "HTML recieved" expected 251 | end; 252 | 253 | "response_secret" -: begin fun () -> 254 | let req = Dream.request ~target:"/totp/generate_secret" ~method_:`GET "" in 255 | let response = Dream.test (html_test_middlewares user_none []) req 256 | and expected = "text/html; charset=utf-8" in 257 | Dream.header response "Content-Type" 258 | |> Option.value ~default:"" 259 | |> Alcotest.(check string) "HTML recieved" expected 260 | end; 261 | 262 | "response_enabled" -: begin fun () -> 263 | let req = Dream.request ~target:"/totp/finish_setup" ~method_:`POST "" in 264 | let otp_code = Twostep.TOTP.code ~secret:(Entity.otp_secret ()) () in 265 | let response = Dream.test (html_test_middlewares user_none [("totp_code", otp_code)]) req 266 | and expected = "text/html; charset=utf-8" in 267 | Dream.header response "Content-Type" 268 | |> Option.value ~default:"" 269 | |> Alcotest.(check string) "HTML recieved" expected 270 | end; 271 | ] -------------------------------------------------------------------------------- /test/strategies/unit.ml: -------------------------------------------------------------------------------- 1 | (*Main test executable*) 2 | 3 | Alcotest.run "FPauth__strategies" [Password.tests; Totp.tests; Totp.json_tests; Totp.html_tests] --------------------------------------------------------------------------------