├── .github └── workflows │ ├── gh-pages.yml │ └── main.yml ├── .gitignore ├── .ocamlformat ├── CHANGELOG.md ├── LICENSE ├── Makefile ├── README.md ├── calculon-web.opam ├── calculon-web.opam.locked ├── calculon.opam ├── calculon.opam.locked ├── demo_bot.sh ├── dune ├── dune-project ├── media └── calculon.jpg ├── redis-bot.sh ├── redis-cat.sh └── src ├── core ├── Command.ml ├── Command.mli ├── Config.ml ├── Config.mli ├── Core.ml ├── DB_utils.ml ├── Irc.ml ├── Plugin.ml ├── Plugin.mli ├── Plugin_factoids.ml ├── Plugin_factoids.mli ├── Plugin_history.ml ├── Plugin_history.mli ├── Plugin_social.ml ├── Plugin_social.mli ├── Plugin_state.ml ├── Plugin_state.mli ├── Plugin_vote.ml ├── Plugin_vote.mli ├── Prelude.ml ├── Prelude.mli ├── Run_main.ml ├── Run_main.mli ├── Signal.ml ├── Signal.mli ├── Talk.ml ├── Talk.mli ├── common │ ├── calculon_common.ml │ └── dune └── dune ├── demo ├── demo_bot.ml └── dune ├── dune ├── extras ├── dune ├── irclog.ml └── irclog.mli ├── tools ├── dune └── migrate_state.ml └── web ├── Giphy.atd ├── Movie.atd ├── Plugin_movie.ml ├── Plugin_web.ml ├── dune ├── movie_schema.ml ├── og.ml └── og.mli /.github/workflows/gh-pages.yml: -------------------------------------------------------------------------------- 1 | name: github pages 2 | 3 | on: 4 | push: 5 | branches: 6 | - master # Set a branch name to trigger deployment 7 | 8 | jobs: 9 | deploy: 10 | runs-on: ubuntu-latest 11 | steps: 12 | - uses: actions/checkout@main 13 | 14 | - name: Cache opam 15 | id: cache-opam 16 | uses: actions/cache@v2 17 | with: 18 | path: ~/.opam 19 | key: opam-ubuntu-latest-4.12.0 20 | 21 | - uses: avsm/setup-ocaml@v1 22 | with: 23 | ocaml-version: '4.12.0' 24 | 25 | - name: Pin 26 | run: opam pin -n . 27 | 28 | - name: Depext 29 | run: opam depext -yt calculon calculon-web 30 | 31 | - name: Deps 32 | run: opam install -d . --deps-only 33 | 34 | - name: Build 35 | run: opam exec -- dune build @doc 36 | 37 | - name: Deploy 38 | uses: peaceiris/actions-gh-pages@v3 39 | with: 40 | github_token: ${{ secrets.GITHUB_TOKEN }} 41 | publish_dir: ./_build/default/_doc/_html/ 42 | destination_dir: dev 43 | enable_jekyll: true 44 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | on: 3 | push: 4 | branches: 5 | - main 6 | pull_request: 7 | jobs: 8 | run: 9 | name: Build 10 | strategy: 11 | matrix: 12 | os: 13 | - ubuntu-latest 14 | #- macos-latest 15 | #- windows-latest 16 | ocaml-compiler: 17 | - 4.08.x 18 | - 5.1.x 19 | runs-on: ${{ matrix.os }} 20 | steps: 21 | - uses: actions/checkout@v2 22 | - uses: ocaml/setup-ocaml@v2 23 | with: 24 | ocaml-compiler: ${{ matrix.ocaml-compiler }} 25 | allow-prerelease-opam: true 26 | - run: opam pin -n . 27 | - run: opam depext -yt calculon calculon-web 28 | - run: opam install -t . --deps-only 29 | - run: opam exec -- dune build @install 30 | - run: opam exec -- dune runtest 31 | if: ${{ matrix.os == 'ubuntu-latest'}} 32 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .*.swp 2 | .*.swo 3 | _build 4 | *.native 5 | *.byte 6 | .session 7 | TAGS 8 | *.docdir 9 | setup.* 10 | qtest* 11 | *.html 12 | *_j.* 13 | *_t.* 14 | .merlin 15 | *.install 16 | *.json 17 | *.db 18 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | version = 0.24.1 2 | profile=conventional 3 | margin=80 4 | if-then-else=k-r 5 | parens-ite=true 6 | parens-tuple=multi-line-only 7 | sequence-style=terminator 8 | type-decl=compact 9 | break-cases=toplevel 10 | cases-exp-indent=2 11 | field-space=tight-decl 12 | leading-nested-match-parens=true 13 | module-item-spacing=compact 14 | quiet=true 15 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 2 | ## 0.8 3 | 4 | - add opam lockfiles 5 | - check channel in !tell 6 | - config: ability to join multiple channels 7 | - remove ISO8601, use ptime instead 8 | - use sqlite3 for storage 9 | * small `migrate_state` tool to produce a db file from state.json 10 | - use github actions 11 | - remove `tls_cert` config option 12 | - factoid: add `max_cardinal_for_force` 13 | - add custom commands (no prefix matching at all) 14 | - count years in !seen 15 | 16 | ## 0.7 17 | 18 | - add emoji plugin 19 | - move to irc-client 0.7 with SASL support 20 | - default to libera.chat 21 | 22 | ## 0.6 23 | 24 | - use `logs` for logging, deprecate custom logger 25 | - better irclogs parser 26 | - use `Yojson.t` 27 | - add `extra_args` to config parser 28 | 29 | ## 0.5 30 | 31 | - refactor: use curly for the web plugin 32 | - refactor: use irc-client-lwt-ssl instead of tls 33 | - chore: make examples/tools native only 34 | - fix `prefix1-full` 35 | - feat: redis interface 36 | - make calculon-extra non-optional 37 | 38 | ## 0.4 39 | 40 | - refactor: pass prefix during matching, not at command creation 41 | - test: use mdx, update readme to compile again 42 | - chore: bump minimal OCaml version to 4.03 43 | - refactor and fix `help` command 44 | - chore: move to dune, including for demo bot 45 | - update documentation 46 | - add travis-ci 47 | - migrate opam file to opam 2.0 48 | - update doc of cmd_help, of_cmd, of_cmds 49 | - add custom prefix for commands 50 | - add command prefix in the description 51 | - TLS client cert support 52 | 53 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 chamo coucouInc Armael Enjolras c-cube 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 6 | 7 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 10 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: build test 2 | 3 | build: 4 | @dune build @all 5 | 6 | install: 7 | @dune install 8 | 9 | test: build 10 | @dune runtest --no-buffer --force 11 | 12 | clean: 13 | @dune clean 14 | 15 | watch: 16 | @dune build @all --watch 17 | 18 | doc: 19 | @dune build @doc 20 | 21 | VERSION=$(shell awk '/^version:/ {print $$2}' calculon.opam) 22 | 23 | update_next_tag: 24 | @echo "update version to $(VERSION)..." 25 | sed -i "s/NEXT_VERSION/$(VERSION)/g" $(wildcard src/**/*.ml) $(wildcard src/**/*.mli) 26 | sed -i "s/NEXT_RELEASE/$(VERSION)/g" $(wildcard src/**/*.ml) $(wildcard src/**/*.mli) 27 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | # Calculon [![build](https://github.com/c-cube/calculon/actions/workflows/main.yml/badge.svg)](https://github.com/c-cube/calculon/actions/workflows/main.yml) 3 | 4 | Library for writing IRC bots in OCaml, a collection of plugins, and a dramatic robotic actor. 5 | The core library is called `calculon`. 6 | 7 | ![calculon logo](https://raw.github.com/c-cube/calculon/master/media/calculon.jpg) 8 | 9 | ## Build 10 | 11 | ``` 12 | make build 13 | ``` 14 | 15 | ## Introduction to the Code 16 | 17 | Let's assume calculon is loaded, via: 18 | 19 | ```ocaml 20 | # #require "calculon";; 21 | ``` 22 | 23 | ### Main 24 | 25 | The typical `main` entry point would look like this. 26 | Calculon works by gathering a list of 27 | *plugins* (see the module `Plugin`), some configuration (see `Config`) 28 | and running the package in a loop using [irc-client](https://github.com/johnelse/ocaml-irc-client/). 29 | 30 | ```ocaml non-deterministic=command 31 | 32 | module C = Calculon 33 | 34 | let plugins : C.Plugin.t list = [ 35 | C.Plugin_social.plugin; 36 | C.Plugin_factoids.plugin; 37 | (* etc. *) 38 | ] 39 | 40 | let () = 41 | let conf = C.Config.of_argv () in 42 | C.Run_main.main conf plugins |> Lwt_main.run 43 | 44 | ``` 45 | 46 | ### Plugins 47 | 48 | A plugin contains a set of *commands*. 49 | A command is is a rule that matches a IRC message with some regex, and decides 50 | whether or not to fire with a reply. They are defined in the module `Command`. 51 | 52 | For instance, the following module will reply to messages 53 | starting with `!hello` by replying `"hello "`. This is a simple 54 | command, as the function `Command.make_simple` indicates: it returns a `string 55 | option` to indicate whether or not to respond to any line starting with 56 | `!prefix`. More elaborate commands are possible using `Command.make`. 57 | 58 | ```ocaml 59 | 60 | open Calculon 61 | 62 | let cmd_hello : Command.t = 63 | Command.make_simple ~descr:"hello world" ~cmd:"hello" ~prio:10 64 | (fun (input_msg:Core.privmsg) _ -> 65 | let who = input_msg.Core.nick in 66 | Lwt.return (Some ("hello " ^ who)) 67 | ) 68 | 69 | let plugin_hello : Plugin.t = Plugin.of_cmd cmd_hello 70 | ``` 71 | 72 | Basic plugins are stateless, built from one or more commands with `Plugin.of_cmd` 73 | and `Plugin.of_cmds`. 74 | Other plugins can be stateful (typically, they can have some persistent 75 | state, or more "custom" schemes). 76 | The constructor `Plugin.stateful` is used to make such plugins. 77 | All the persistent state is stored in a single json file. 78 | 79 | See for instance the existing plugins `Plugin_factoids` and `Plugin_movie` 80 | to see how to use `Plugin.stateful`. 81 | -------------------------------------------------------------------------------- /calculon-web.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.8" 4 | synopsis: "A collection of web plugins for Calculon" 5 | authors: ["c-cube" "Enjolras" "Armael"] 6 | license: "MIT" 7 | homepage: "https://github.com/c-cube/calculon" 8 | bug-reports: "https://github.com/c-cube/calculon/issues" 9 | depends: [ 10 | "dune" 11 | "calculon" {= version} 12 | "re" {>= "1.7.2"} 13 | "uri" 14 | "curly" 15 | "atdgen" 16 | "lambdasoup" 17 | "odoc" {with-doc} 18 | ] 19 | build: [ 20 | ["dune" "subst"] {pinned} 21 | [ 22 | "dune" 23 | "build" 24 | "-p" 25 | name 26 | "-j" 27 | jobs 28 | "@install" 29 | "@runtest" {with-test} 30 | "@doc" {with-doc} 31 | ] 32 | ] 33 | dev-repo: "git+https://github.com/c-cube/calculon.git" 34 | -------------------------------------------------------------------------------- /calculon-web.opam.locked: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "calculon-web" 3 | version: "0.7" 4 | synopsis: "A collection of web plugins for Calculon" 5 | maintainer: "c-cube" 6 | authors: ["Armael" "Enjolras" "c-cube"] 7 | license: "MIT" 8 | tags: ["irc" "bot" "factoids"] 9 | homepage: "https://github.com/c-cube/calculon" 10 | bug-reports: "https://github.com/c-cube/calculon/issues" 11 | depends: [ 12 | "angstrom" {= "0.15.0"} 13 | "atd" {= "2.2.1"} 14 | "atdgen" {= "2.2.1"} 15 | "atdgen-runtime" {= "2.2.1"} 16 | "base-bigarray" {= "base"} 17 | "base-bytes" {= "base"} 18 | "base-threads" {= "base"} 19 | "base-unix" {= "base"} 20 | "base64" {= "3.5.0"} 21 | "bigarray-compat" {= "1.1.0"} 22 | "bigstringaf" {= "0.8.0"} 23 | "biniou" {= "1.2.1"} 24 | "calculon" {= "0.7"} 25 | "conf-libssl" {= "3"} 26 | "conf-pkg-config" {= "2"} 27 | "conf-sqlite3" {= "1"} 28 | "containers" {= "3.6.1"} 29 | "cppo" {= "1.6.8"} 30 | "csexp" {= "1.5.1"} 31 | "curly" {= "0.2.0"} 32 | "dune" {= "3.0.3"} 33 | "dune-configurator" {= "3.0.3"} 34 | "easy-format" {= "1.3.2"} 35 | "either" {= "1.0.0"} 36 | "irc-client" {= "0.7.0"} 37 | "irc-client-lwt" {= "0.7.0"} 38 | "irc-client-lwt-ssl" {= "0.7.0"} 39 | "iter" {= "1.4"} 40 | "lambdasoup" {= "0.7.3"} 41 | "logs" {= "0.7.0"} 42 | "lwt" {= "5.5.0"} 43 | "lwt_ssl" {= "1.1.3"} 44 | "markup" {= "1.0.2"} 45 | "menhir" {= "20211128"} 46 | "menhirLib" {= "20211128"} 47 | "menhirSdk" {= "20211128"} 48 | "mmap" {= "1.2.0"} 49 | "ocaml" {= "4.08.1"} 50 | "ocaml-base-compiler" {= "4.08.1"} 51 | "ocaml-config" {= "1"} 52 | "ocaml-syntax-shims" {= "1.0.0"} 53 | "ocamlbuild" {= "0.14.1"} 54 | "ocamlfind" {= "1.9.3"} 55 | "ocplib-endian" {= "1.2"} 56 | "ptime" {= "1.0.0"} 57 | "re" {= "1.10.3"} 58 | "result" {= "1.5"} 59 | "seq" {= "base"} 60 | "sqlite3" {= "5.0.2"} 61 | "ssl" {= "0.5.10"} 62 | "stringext" {= "1.6.0"} 63 | "topkg" {= "1.0.5"} 64 | "uchar" {= "0.0.2"} 65 | "uri" {= "4.2.0"} 66 | "uutf" {= "1.0.3"} 67 | "yojson" {= "1.7.0"} 68 | ] 69 | build: [ 70 | ["dune" "build" "-p" name "-j" jobs] 71 | ["dune" "build" "@doc" "-p" name] {with-doc} 72 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 73 | ] 74 | dev-repo: "git+https://github.com/c-cube/calculon.git" -------------------------------------------------------------------------------- /calculon.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | version: "0.8" 4 | authors: ["c-cube" "Enjolras" "Armael"] 5 | license: "MIT" 6 | tags: ["irc" "bot" "factoids"] 7 | homepage: "https://github.com/c-cube/calculon" 8 | bug-reports: "https://github.com/c-cube/calculon/issues" 9 | depends: [ 10 | "dune" {>= "1.1"} 11 | "base-unix" 12 | "lwt" 13 | "irc-client" {>= "0.7.0"} 14 | "irc-client-lwt" 15 | "irc-client-lwt-ssl" 16 | "sqlite3" {>= "5.0.0"} 17 | "logs" {>= "0.5.0"} 18 | "yojson" {>= "1.7"} 19 | "containers" {>= "3.6" & < "4.0"} 20 | "ptime" 21 | "stringext" 22 | "re" {>= "1.7.2" & < "2.0"} 23 | "odoc" {with-doc} 24 | "ocaml" {>= "4.08.0"} 25 | ] 26 | depopts: ["iter"] 27 | build: [ 28 | ["dune" "subst"] {pinned} 29 | [ 30 | "dune" 31 | "build" 32 | "-p" 33 | name 34 | "-j" 35 | jobs 36 | "@install" 37 | "@runtest" {with-test} 38 | "@doc" {with-doc} 39 | ] 40 | ] 41 | dev-repo: "git+https://github.com/c-cube/calculon.git" 42 | -------------------------------------------------------------------------------- /calculon.opam.locked: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "calculon" 3 | version: "0.7" 4 | synopsis: "Library for writing IRC bots in OCaml and a collection of plugins" 5 | maintainer: "c-cube" 6 | authors: ["Armael" "Enjolras" "c-cube"] 7 | license: "MIT" 8 | tags: ["irc" "bot" "factoids"] 9 | homepage: "https://github.com/c-cube/calculon" 10 | bug-reports: "https://github.com/c-cube/calculon/issues" 11 | depends: [ 12 | "base-bigarray" {= "base"} 13 | "base-bytes" {= "base"} 14 | "base-threads" {= "base"} 15 | "base-unix" {= "base"} 16 | "base64" {= "3.5.0"} 17 | "bigarray-compat" {= "1.1.0"} 18 | "biniou" {= "1.2.1"} 19 | "conf-libssl" {= "3"} 20 | "conf-pkg-config" {= "2"} 21 | "conf-sqlite3" {= "1"} 22 | "containers" {= "3.6.1"} 23 | "cppo" {= "1.6.8"} 24 | "csexp" {= "1.5.1"} 25 | "dune" {= "3.0.3"} 26 | "dune-configurator" {= "3.0.3"} 27 | "easy-format" {= "1.3.2"} 28 | "either" {= "1.0.0"} 29 | "irc-client" {= "0.7.0"} 30 | "irc-client-lwt" {= "0.7.0"} 31 | "irc-client-lwt-ssl" {= "0.7.0"} 32 | "iter" {= "1.4"} 33 | "logs" {= "0.7.0"} 34 | "lwt" {= "5.5.0"} 35 | "lwt_ssl" {= "1.1.3"} 36 | "mmap" {= "1.2.0"} 37 | "ocaml" {= "4.08.1"} 38 | "ocaml-base-compiler" {= "4.08.1"} 39 | "ocaml-config" {= "1"} 40 | "ocaml-syntax-shims" {= "1.0.0"} 41 | "ocamlbuild" {= "0.14.1"} 42 | "ocamlfind" {= "1.9.3"} 43 | "ocplib-endian" {= "1.2"} 44 | "ptime" {= "1.0.0"} 45 | "re" {= "1.10.3"} 46 | "result" {= "1.5"} 47 | "seq" {= "base"} 48 | "sqlite3" {= "5.0.2"} 49 | "ssl" {= "0.5.10"} 50 | "stringext" {= "1.6.0"} 51 | "topkg" {= "1.0.5"} 52 | "yojson" {= "1.7.0"} 53 | ] 54 | build: [ 55 | ["dune" "build" "-p" name "-j" jobs] 56 | ["dune" "build" "@doc" "-p" name] {with-doc} 57 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 58 | ] 59 | dev-repo: "git+https://github.com/c-cube/calculon.git" -------------------------------------------------------------------------------- /demo_bot.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec dune exec src/demo/demo_bot.exe --no-buffer -- $@ 4 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (flags 4 | (:standard -warn-error -3 -w -70)))) 5 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.0) 2 | (name calculon) 3 | (generate_opam_files true) 4 | 5 | (version 0.8) 6 | 7 | (source 8 | (github c-cube/calculon)) 9 | 10 | (license MIT) 11 | 12 | (authors c-cube Enjolras Armael) 13 | 14 | (package 15 | (name calculon) 16 | (depends 17 | ("dune" 18 | (>= "1.1")) 19 | "base-unix" 20 | "lwt" 21 | ("irc-client" 22 | (>= "0.7.0")) 23 | "irc-client-lwt" 24 | "irc-client-lwt-ssl" 25 | ("sqlite3" 26 | (>= "5.0.0")) 27 | ("logs" 28 | (>= "0.5.0")) 29 | ("yojson" 30 | (>= "1.7")) 31 | ("containers" 32 | (and 33 | (>= "3.6") 34 | (< "4.0"))) 35 | "ptime" 36 | "stringext" 37 | ("re" 38 | (and 39 | (>= "1.7.2") 40 | (< "2.0"))) 41 | ("odoc" :with-doc) 42 | ("ocaml" 43 | (>= "4.08.0"))) 44 | (depopts iter) 45 | (tags 46 | ("irc" "bot" "factoids"))) 47 | 48 | (package 49 | (name calculon-web) 50 | (synopsis "A collection of web plugins for Calculon") 51 | (depends 52 | "dune" 53 | ("calculon" 54 | (= :version)) 55 | ("re" 56 | (>= "1.7.2")) 57 | "uri" 58 | "curly" 59 | "atdgen" 60 | "lambdasoup" 61 | ("odoc" :with-doc))) 62 | -------------------------------------------------------------------------------- /media/calculon.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/c-cube/calculon/a7f06ae8de82da4ecd1e8b90e89d7b6d2044f8d7/media/calculon.jpg -------------------------------------------------------------------------------- /redis-bot.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec dune exec src/redis-bot/redis_bot.exe -- $@ 4 | -------------------------------------------------------------------------------- /redis-cat.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | exec dune exec src/redis-cat/redis_cat.exe -- $@ 4 | -------------------------------------------------------------------------------- /src/core/Command.ml: -------------------------------------------------------------------------------- 1 | (** {1 Command Type} *) 2 | 3 | open Lwt_infix 4 | 5 | type res = Cmd_match of unit Lwt.t | Cmd_skip | Cmd_fail of string 6 | 7 | type t = { 8 | prio: int; 9 | match_: prefix:string -> Core.t -> Core.privmsg -> res; 10 | (** How to react to incoming messages *) 11 | name: string; 12 | descr: string; 13 | } 14 | 15 | let make ?(descr = "") ?(prio = 99) ~name f = { descr; prio; name; match_ = f } 16 | 17 | let extract_hl s = 18 | try 19 | let i = String.rindex s '>' in 20 | if i < String.length s - 1 then ( 21 | let hl = String.sub s (i + 1) (String.length s - i - 1) |> String.trim in 22 | let s = String.sub s 0 i |> String.trim in 23 | Some (s, hl) 24 | ) else 25 | None 26 | with Not_found -> None 27 | 28 | let match_prefix1_full ~prefix ~cmd msg : (string * string option) option = 29 | let re = 30 | Re.Perl.compile_pat (Printf.sprintf "^%s\\b[ ]*%s\\b[ ]*(.*)$" prefix cmd) 31 | in 32 | match Prelude.re_match1 id re msg.Core.message with 33 | | None -> None 34 | | Some matched -> 35 | let matched = String.trim matched in 36 | (match extract_hl matched with 37 | | None -> Some (matched, None) 38 | | Some (a, b) -> Some (a, Some b)) 39 | 40 | let match_prefix1 ~prefix ~cmd msg = 41 | Option.map fst (match_prefix1_full ~prefix ~cmd msg) 42 | 43 | exception Fail of string 44 | 45 | let make_simple_inner_ ~query ?descr ?prio ~cmd f : t = 46 | let match_ ~prefix (module C : Core.S) msg = 47 | match match_prefix1_full ~prefix ~cmd msg with 48 | | None -> Cmd_skip 49 | | Some (sub, hl) -> 50 | Core.Log.debug (fun k -> 51 | k "command '%s' matched with sub=%S, hl=%s" prefix sub 52 | (match hl with 53 | | None -> "none" 54 | | Some h -> Printf.sprintf "%S" h)); 55 | (try 56 | let fut = 57 | let* lines = f msg sub in 58 | let lines = 59 | match hl with 60 | | None -> lines 61 | | Some hl -> List.map (fun line -> hl ^ ": " ^ line) lines 62 | in 63 | let target = 64 | if query then 65 | Core.nick msg 66 | else 67 | Core.reply_to msg 68 | in 69 | let delay = 70 | if query then 71 | Some 0.5 72 | else 73 | None 74 | in 75 | C.send_privmsg_l_nolimit ?delay ~target ~messages:lines () 76 | in 77 | Cmd_match fut 78 | with Fail msg -> Cmd_fail msg) 79 | in 80 | make ?descr ?prio ~name:cmd match_ 81 | 82 | let make_simple_l ?descr ?prio ~cmd f : t = 83 | let descr = 84 | match descr with 85 | | None -> cmd 86 | | Some s -> s 87 | in 88 | make_simple_inner_ ~query:false ~descr ?prio ~cmd f 89 | 90 | let make_simple_query_l ?descr ?prio ~cmd f : t = 91 | let descr = 92 | match descr with 93 | | Some s -> s 94 | | None -> cmd 95 | in 96 | make_simple_inner_ ~query:true ~descr ?prio ~cmd f 97 | 98 | let make_custom ?descr ?prio ~name f = 99 | let match_ ~prefix:_ (module C : Core.S) msg = 100 | match f msg msg.Core.message with 101 | | None -> Cmd_skip 102 | | Some fut -> 103 | Cmd_match 104 | ( fut >>= fun lines -> 105 | let target = Core.reply_to msg in 106 | C.send_privmsg_l_nolimit ~target ~messages:lines () ) 107 | | exception e -> Cmd_fail (Printexc.to_string e) 108 | in 109 | make ?descr ?prio ~name match_ 110 | 111 | let make_simple ?descr ?prio ~cmd f : t = 112 | make_simple_l ?descr ?prio ~cmd (fun msg s -> 113 | f msg s >|= function 114 | | None -> [] 115 | | Some x -> [ x ]) 116 | 117 | let compare_prio c1 c2 = compare c1.prio c2.prio 118 | 119 | (** Help command *) 120 | let cmd_help (l : t list) : t = 121 | make_simple ~descr:"help message" ~cmd:"help" ~prio:5 (fun _ s -> 122 | let s = String.trim s in 123 | let res = 124 | match s with 125 | | "" -> 126 | let l = "help" :: List.map (fun c -> c.name) l in 127 | let message = 128 | "help: commands are " ^ Prelude.string_list_to_string l 129 | in 130 | Some message 131 | | "help" -> Some "displays help for commands" 132 | | _ -> 133 | (try 134 | let c = List.find (fun c -> c.name = s) l in 135 | Some (Printf.sprintf "%s: %s (prio %d)" c.name c.descr c.prio) 136 | with Not_found -> Some ("error: unknown command " ^ s)) 137 | in 138 | Lwt.return res) 139 | 140 | let run ~prefix core l msg : unit Lwt.t = 141 | let rec aux = function 142 | | [] -> 143 | Logs.debug (fun k -> 144 | k "no command found for %s" (Core.string_of_privmsg msg)); 145 | Lwt.return_unit 146 | | c :: tail -> 147 | (match c.match_ ~prefix core msg with 148 | | Cmd_skip -> aux tail 149 | | Cmd_match f -> 150 | Logs.debug (fun k -> 151 | k "command %s succeeded for %s" c.name (Core.string_of_privmsg msg)); 152 | f 153 | | Cmd_fail e -> 154 | Logs.debug (fun k -> 155 | k "command %s failed on %s with %s" c.name 156 | (Core.string_of_privmsg msg) 157 | e); 158 | aux tail) 159 | in 160 | aux l 161 | -------------------------------------------------------------------------------- /src/core/Command.mli: -------------------------------------------------------------------------------- 1 | (** {1 Command Type} 2 | 3 | A command is a particular rule for reacting to what is said on IRC. 4 | Typically, a command takes a {!Core.t} (to be able to answer 5 | and perform IRC actions) and an input message, and it decides 6 | whether to do something or not based on the message. 7 | 8 | The command returns a {!res}, which specifies whether it successfully 9 | "caught" the message (no need then for other commands to run), 10 | if it didn't react ("skip") so we can try the other commands, 11 | or whether it failed when trying to answer. 12 | *) 13 | 14 | type res = 15 | | Cmd_match of unit Lwt.t (** command applies, and fired with given action *) 16 | | Cmd_skip (** the command did not apply *) 17 | | Cmd_fail of string (** command applies, but failed *) 18 | 19 | type t = { 20 | prio: int; (** Priority. The lower, the more urgent this command is. *) 21 | match_: prefix:string -> Core.t -> Core.privmsg -> res; 22 | (** How to react to incoming messages *) 23 | name: string; (** Name of the command *) 24 | descr: string; (** For !help *) 25 | } 26 | (** A command, bundling some metadata (name + descr, used for "!help"), 27 | a priority (used to run some commands before the others), 28 | and the answering function itself *) 29 | 30 | val match_prefix1 : prefix:string -> cmd:string -> Core.privmsg -> string option 31 | (** [match_prefix1 ~prefix:"foo" msg] 32 | 33 | - if [msg="!foo bar"], returns [Some bar] 34 | - if [msg="!something else"], returns [None] 35 | *) 36 | 37 | val extract_hl : string -> (string * string) option 38 | (** [extract_hl "foo > bar"] returns [Some ("foo", "bar")]. 39 | Returns [None] if it cannot split on ">" cleanly. *) 40 | 41 | val match_prefix1_full : 42 | prefix:string -> cmd:string -> Core.privmsg -> (string * string option) option 43 | (** @return [Some (msg, hl)] if [msg] matches the regex, 44 | and [hl] is either [Some foo] if the message ended with "> hl", 45 | [None] otherwise *) 46 | 47 | val make : 48 | ?descr:string -> 49 | ?prio:int -> 50 | name:string -> 51 | (prefix:string -> Core.t -> Core.privmsg -> res) -> 52 | t 53 | (** Make a command using the given methods. Only the name and 54 | matching rules are requested *) 55 | 56 | exception Fail of string 57 | 58 | val make_simple : 59 | ?descr:string -> 60 | ?prio:int -> 61 | cmd:string -> 62 | (Core.privmsg -> string -> string option Lwt.t) -> 63 | t 64 | (** [make_simple ~cmd f] matches messages of the form "!cmd xxx", 65 | and call [f msg "xxx"]. The function returns 0 or 1 line to reply to sender. 66 | The function can raise Fail to indicate failure *) 67 | 68 | val make_simple_l : 69 | ?descr:string -> 70 | ?prio:int -> 71 | cmd:string -> 72 | (Core.privmsg -> string -> string list Lwt.t) -> 73 | t 74 | (** Same as {!make_simple} but replies lines 75 | The function can raise Fail to indicate failure *) 76 | 77 | val make_simple_query_l : 78 | ?descr:string -> 79 | ?prio:int -> 80 | cmd:string -> 81 | (Core.privmsg -> string -> string list Lwt.t) -> 82 | t 83 | (** Same as {!make_simple_l} but replies lines in query (private) 84 | The function can raise Fail to indicate failure *) 85 | 86 | val make_custom : 87 | ?descr:string -> 88 | ?prio:int -> 89 | name:string -> 90 | (Core.privmsg -> string -> string list Lwt.t option) -> 91 | t 92 | (** [make_custom ~name f] calls [f] on input messages, 93 | and returns either: 94 | - [future(Some l)] to send some lines in response 95 | - [None] to abstain and let other commands handle this message. 96 | 97 | No prefix is considered here. 98 | @since 0.8 99 | *) 100 | 101 | val compare_prio : t -> t -> int 102 | (** Compare by priority. Used to sort a list of commands by their priority. *) 103 | 104 | val cmd_help : t list -> t 105 | (** [cmd_help l] build a command [help] that print a help 106 | message about plugins in l. *) 107 | 108 | val run : prefix:string -> Core.t -> t list -> Core.privmsg -> unit Lwt.t 109 | (** Execute the commands, in given order, on the message. First command 110 | to succeed shortcuts the other ones. *) 111 | -------------------------------------------------------------------------------- /src/core/Config.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | 3 | type hidden = Hidden 4 | 5 | type t = { 6 | server : string; 7 | port : int; 8 | username : string; 9 | password : string option; 10 | realname : string; 11 | nick : string; 12 | tls: bool; 13 | sasl: bool; 14 | channels : string list; 15 | log_level: Logs.level; 16 | prefix: string; 17 | db_file: string; 18 | _hidden: hidden; 19 | } 20 | 21 | let default = { 22 | server = "irc.libera.chat"; 23 | port = 7000; 24 | username = "calculon"; 25 | password = None; 26 | realname = "calculon"; 27 | nick = "calculon"; 28 | tls = true; 29 | sasl = true; 30 | channels = ["#ocaml"]; 31 | log_level=Logs.Info; 32 | prefix = "!"; 33 | db_file="calculon.db"; 34 | _hidden=Hidden; 35 | } 36 | 37 | let parse ?(extra_args=[]) conf args = 38 | let custom_nick = ref None in 39 | let custom_chan = ref [] in 40 | let custom_server = ref None in 41 | let custom_db_file = ref None in 42 | let custom_port = ref conf.port in 43 | let custom_tls = ref None in 44 | let custom_sasl = ref None in 45 | let prefix = ref default.prefix in 46 | let log_lvl = ref None in 47 | let options = Arg.align @@ extra_args @ 48 | [ "--nick", Arg.String (fun s -> custom_nick := Some s), 49 | " custom nickname (default: " ^ default.nick ^ ")" 50 | ; "--chan", Arg.String (fun s -> custom_chan := s :: !custom_chan), 51 | " channel to join (default: " ^ String.concat "," default.channels ^ ")" 52 | ; "--port", Arg.Set_int custom_port, " port of the server" 53 | ; "--server", Arg.String (fun s -> custom_server := Some s), 54 | " server to join (default: " ^ default.server ^ ")" 55 | ; "--db-file", Arg.String (fun s -> custom_db_file := Some s), 56 | " database file containing plugin state (default: " ^ default.db_file ^ ")" 57 | ; "--tls", Arg.Bool (fun b -> custom_tls := Some b), " enable/disable TLS" 58 | ; "--sasl", Arg.Bool (fun b -> custom_sasl := Some b), " enable/disable SASL auth" 59 | ; "--debug", Arg.Unit (fun() ->log_lvl := Some Logs.Debug), " set log level to debug" 60 | ; "--prefix", Arg.Set_string prefix, " set prefix for commands (default \"!\")"; 61 | ] 62 | in 63 | Arg.parse_argv args options ignore "parse options"; 64 | 65 | (* env vars are also used *) 66 | let user = 67 | try Sys.getenv "USER" with _ -> conf.username 68 | and password = 69 | try Some (Sys.getenv "PASSWORD") with _ -> None 70 | in 71 | 72 | { conf with 73 | nick = !custom_nick |? conf.nick; 74 | username = user; 75 | password; 76 | channels = (if !custom_chan=[] then conf.channels else !custom_chan); 77 | server = !custom_server |? conf.server; 78 | tls = !custom_tls |? conf.tls; 79 | sasl = !custom_sasl |? conf.sasl; 80 | port = !custom_port; 81 | db_file = !custom_db_file |? conf.db_file; 82 | log_level = !log_lvl |? conf.log_level; 83 | prefix = !prefix; 84 | } 85 | 86 | let of_argv ?extra_args () = 87 | try parse ?extra_args default Sys.argv 88 | with 89 | | Arg.Bad msg -> print_endline msg; exit 1 90 | | Arg.Help msg -> print_endline msg; exit 0 91 | -------------------------------------------------------------------------------- /src/core/Config.mli: -------------------------------------------------------------------------------- 1 | (** User-defined config *) 2 | 3 | type hidden (** Type that cannot be built *) 4 | 5 | type t = { 6 | server : string; (** Address of the irc server *) 7 | port : int; (** Port of the server *) 8 | username : string; 9 | password : string option; 10 | realname : string; 11 | nick : string; 12 | tls: bool; 13 | sasl: bool; 14 | channels : string list; (** Channels to join after the connexion to the server *) 15 | 16 | log_level: Logs.level; 17 | (** Level of logging. 18 | @since 0.6 *) 19 | 20 | prefix: string; (** prefix for commands *) 21 | 22 | db_file: string; 23 | (** Database path. @since 0.8 *) 24 | 25 | _hidden: hidden; 26 | (** This field is present to prevent the user from using a literal 27 | record to build configuration. This way, adding new fields 28 | doesn't break existing code. 29 | 30 | @since 0.8 *) 31 | } 32 | (** Bot configuration. *) 33 | 34 | val default : t 35 | (** Default configuration: 36 | - server = "irc.libera.chat" 37 | - port = 7000 38 | - username = "calculon" 39 | - realname = "calculon" 40 | - password = None 41 | - nick = "calculon" 42 | - tls = true 43 | - sasl = true 44 | - channel = "#ocaml" 45 | - irc_log = `None 46 | - log_level = Logs.Warning 47 | - prefix = "!" 48 | - db_file = "calculon.db" 49 | *) 50 | 51 | val parse : 52 | ?extra_args:(string * Arg.spec * string) list -> 53 | t -> string array -> t 54 | (** [parse conf args] is the same as [conf], but some command line 55 | arguments can override its fields 56 | @param extra_args additional command line arguments for {!Arg} (since 0.8) 57 | *) 58 | 59 | val of_argv : 60 | ?extra_args:(string * Arg.spec * string) list -> 61 | unit -> t 62 | (** Parsed from {!Sys.argv} 63 | Will call {!exit} if [Arg.parse] fails 64 | @param extra_args additional command line arguments for {!Arg} (since 0.8) 65 | *) 66 | -------------------------------------------------------------------------------- /src/core/Core.ml: -------------------------------------------------------------------------------- 1 | (** {1 Core IRC state} *) 2 | 3 | module Format_ = Format 4 | open Prelude 5 | open Lwt_infix 6 | module Msg = Irc_message 7 | 8 | let logs_src = Logs.Src.create ~doc:"logs for calculon" "calculon" 9 | 10 | module Log = (val Logs.src_log logs_src) 11 | 12 | type irc_msg = Irc_message.t 13 | 14 | type privmsg = { 15 | nick: string; (* author *) 16 | to_: string; (* target *) 17 | message: string; 18 | } 19 | 20 | let is_chan s = 21 | (not (String.equal s "")) 22 | && Char.equal s.[0] '#' 23 | && not (String.contains s ' ') 24 | 25 | let nick msg = msg.nick 26 | 27 | let reply_to msg = 28 | if is_chan msg.to_ then 29 | msg.to_ 30 | (* reply on same channel *) 31 | else 32 | msg.nick 33 | (* in pv *) 34 | 35 | let privmsg_of_msg msg = 36 | match msg.Msg.command with 37 | | Msg.PRIVMSG (to_, message) -> 38 | Some 39 | { 40 | nick = Option.get_or "msg prefix" msg.Msg.prefix |> get_nick; 41 | to_; 42 | message; 43 | } 44 | | _ -> None 45 | 46 | let string_of_privmsg msg = 47 | Printf.sprintf "{nick:%S; to:%S; msg: %S}" msg.nick msg.to_ msg.message 48 | 49 | module type S = sig 50 | module I : Irc_client.CLIENT with type 'a Io.t = 'a Lwt.t 51 | 52 | type connection = I.connection_t 53 | 54 | val connection : connection 55 | val init : unit Lwt.t 56 | val exit : unit Lwt.t 57 | val send_exit : unit -> unit 58 | val messages : Msg.t Signal.t 59 | val privmsg : privmsg Signal.t 60 | 61 | val line_cut_threshold : int ref 62 | (** Above [!line_cut_threshold], multi-line messages are cut with "..." *) 63 | 64 | val send_privmsg_l : target:string -> messages:string list -> unit Lwt.t 65 | 66 | val send_privmsg_l_nolimit : 67 | ?delay:float -> target:string -> messages:string list -> unit -> unit Lwt.t 68 | (** Version of {!send_privmsg_l} that does not enforce cut threshold. 69 | @param delay optional delay between each sent message *) 70 | 71 | val send_privmsg : target:string -> message:string -> unit Lwt.t 72 | (** Helper for sending messages, splitting lines, etc. *) 73 | 74 | val send_notice_l : target:string -> messages:string list -> unit Lwt.t 75 | 76 | val send_notice : target:string -> message:string -> unit Lwt.t 77 | (** Helper for sending notices, splitting lines, etc. *) 78 | 79 | val send_join : channel:string -> unit Lwt.t 80 | val send_part : channel:string -> unit Lwt.t 81 | val talk : target:string -> Talk.t -> unit Lwt.t 82 | end 83 | 84 | type t = (module S) 85 | 86 | module Make 87 | (I : Irc_client.CLIENT with type 'a Io.t = 'a Lwt.t) (Conn : sig 88 | val c : I.connection_t 89 | end) = 90 | struct 91 | module I = I 92 | 93 | type connection = I.connection_t 94 | 95 | let connection = Conn.c 96 | let init = Lwt.return_unit (* already done! *) 97 | let exit, send_exit = Lwt.wait () 98 | let send_exit () = Lwt.wakeup send_exit () 99 | let messages = Signal.create () 100 | let privmsg = Signal.filter_map messages privmsg_of_msg 101 | let line_cut_threshold = ref 10 102 | 103 | let process_list_ ?(bypass_limit = false) ?sep ~f ~target ~messages:lines () = 104 | (* keep at most 4, unless [bypass_limit=true] *) 105 | let lines = 106 | let len = List.length lines in 107 | if (not bypass_limit) && len > !line_cut_threshold then 108 | CCList.take 4 lines @ [ Printf.sprintf "(…%d more lines…)" (len - 4) ] 109 | else 110 | lines 111 | in 112 | let delay_between = ref 0.3 in 113 | Lwt_list.iter_s 114 | (fun message -> 115 | let* () = f ~connection ~target ~message in 116 | let* () = Lwt_unix.sleep !delay_between in 117 | delay_between := CCFloat.min (!delay_between +. 0.2) 1.0; 118 | match sep with 119 | | None -> Lwt.return () 120 | | Some f -> f ()) 121 | lines 122 | 123 | let split_lines_ = CCString.Split.list_cpy ~by:"\n" 124 | let flat_map = CCList.flat_map 125 | 126 | let send_privmsg_l ~target ~messages = 127 | process_list_ ~f:I.send_privmsg ~target 128 | ~messages:(flat_map split_lines_ messages) 129 | () 130 | 131 | let send_privmsg_l_nolimit ?(delay = 0.5) ~target ~messages () = 132 | process_list_ ~f:I.send_privmsg 133 | ~sep:(fun () -> Lwt_unix.sleep delay) 134 | ~target ~bypass_limit:true 135 | ~messages:(flat_map split_lines_ messages) 136 | () 137 | 138 | let send_notice_l ~target ~messages = 139 | process_list_ ~f:I.send_notice ~target ~bypass_limit:false 140 | ~messages:(flat_map split_lines_ messages) 141 | () 142 | 143 | let send_privmsg ~target ~message = 144 | process_list_ ~target ~messages:(split_lines_ message) ~f:I.send_privmsg () 145 | 146 | let send_notice ~target ~message = 147 | process_list_ ~target ~messages:(split_lines_ message) ~f:I.send_notice () 148 | 149 | let send_join ~channel = I.send_join ~connection ~channel 150 | 151 | let send_part ~channel = 152 | I.send ~connection 153 | Irc_message.{ prefix = None; command = PART ([ channel ], "bye y'all") } 154 | 155 | let talk ~target ty = 156 | let message = Talk.select ty in 157 | send_privmsg ~target ~message 158 | end 159 | 160 | module Run 161 | (I : Irc_client.CLIENT with type 'a Io.t = 'a Lwt.t) (F : sig 162 | val connect : unit -> I.connection_t option Lwt.t 163 | val conn_info : string 164 | val init : t -> unit Lwt.t 165 | end) = 166 | struct 167 | let run () : unit Lwt.t = 168 | let self : t option ref = ref None in 169 | I.reconnect_loop 170 | ~keepalive:{ I.mode = `Passive; timeout = 300 } 171 | ~after:60 172 | ~connect:(fun () -> 173 | Log.info (fun k -> 174 | k "trying to (re)connect%s…" 175 | (if String.equal F.conn_info "" then 176 | "" 177 | else 178 | " to " ^ F.conn_info)); 179 | F.connect ()) 180 | ~callback:(fun _ msg_or_err -> 181 | match !self with 182 | | None -> Lwt.return () 183 | | Some (module C) -> 184 | (match msg_or_err with 185 | | Result.Ok msg -> Signal.send C.messages msg 186 | | Result.Error err -> 187 | Log.err (fun k -> k "error: %s" err); 188 | Lwt.return ())) 189 | ~f:(fun conn -> 190 | Log.info (fun k -> k "connected, instantiate core"); 191 | let module C = 192 | Make 193 | (I) 194 | (struct 195 | let c = conn 196 | end) 197 | in 198 | let new_c = (module C : S) in 199 | self := Some new_c; 200 | F.init new_c) 201 | () 202 | end 203 | 204 | let loop_ssl ?(conn_info = "") ~connect ~init () : unit Lwt.t = 205 | let module R = 206 | Run 207 | (Irc_client_lwt_ssl) 208 | (struct 209 | let connect = connect 210 | let conn_info = conn_info 211 | let init = init 212 | end) 213 | in 214 | R.run () 215 | 216 | let loop_unsafe ?(conn_info = "") ~connect ~init () : unit Lwt.t = 217 | let module R = 218 | Run 219 | (Irc_client_lwt) 220 | (struct 221 | let connect = connect 222 | let conn_info = conn_info 223 | let init = init 224 | end) 225 | in 226 | R.run () 227 | 228 | let run conf ~init () = 229 | let module C = Config in 230 | let init (core : t) = 231 | let (module C) = core in 232 | init core 233 | in 234 | let conn_info = Printf.sprintf "%s/%d" conf.C.server conf.C.port in 235 | if conf.C.tls then ( 236 | let tls_config = Irc_client_lwt_ssl.Config.default in 237 | let connect () = 238 | Irc_client_lwt_ssl.connect_by_name ~username:conf.C.username 239 | ~realname:conf.C.realname ~nick:conf.C.nick ?password:conf.C.password 240 | ~server:conf.C.server ~port:conf.C.port ~config:tls_config 241 | ~sasl:conf.C.sasl () 242 | in 243 | loop_ssl ~conn_info ~connect ~init () 244 | ) else ( 245 | let connect () = 246 | Irc_client_lwt.connect_by_name ~username:conf.C.username 247 | ~realname:conf.C.realname ~nick:conf.C.nick ~server:conf.C.server 248 | ~port:conf.C.port () 249 | in 250 | loop_unsafe ~conn_info ~connect ~init () 251 | ) 252 | -------------------------------------------------------------------------------- /src/core/DB_utils.ml: -------------------------------------------------------------------------------- 1 | 2 | module DB = Sqlite3 3 | 4 | (* check DB errors *) 5 | let[@inline] check_db_ db rc = 6 | if DB.Rc.is_success rc || rc = DB.Rc.ROW then () 7 | else failwith (Printf.sprintf "DB error: %s %s" (DB.Rc.to_string rc) (DB.errmsg db)) 8 | 9 | let with_stmt db q f = 10 | let stmt = DB.prepare db q in 11 | let close() = DB.finalize stmt |> check_db_ db in 12 | try let x = f stmt in close(); x 13 | with e -> close(); raise e 14 | -------------------------------------------------------------------------------- /src/core/Irc.ml: -------------------------------------------------------------------------------- 1 | module Config = struct 2 | type t = { check_certificate: bool; proto: Ssl.protocol } 3 | 4 | let default = { check_certificate = false; proto = Ssl.TLSv1_3 } 5 | end 6 | 7 | module Io_ssl = struct 8 | type 'a t = 'a 9 | 10 | let[@inline] ( >>= ) x f = f x 11 | let[@inline] ( >|= ) x f = f x 12 | let[@inline] return x = x 13 | 14 | type file_descr = { 15 | ssl: Ssl.context; 16 | sslsock: Ssl.socket; 17 | fd: Unix.file_descr; 18 | } 19 | 20 | type config = Config.t 21 | type inet_addr = Unix.inet_addr 22 | 23 | let open_socket ?(config = Config.default) addr port : file_descr t = 24 | let ssl = Ssl.create_context config.Config.proto Ssl.Client_context in 25 | if config.Config.check_certificate then ( 26 | (* from https://github.com/johnelse/ocaml-irc-client/pull/21 *) 27 | Ssl.set_verify_depth ssl 3; 28 | Ssl.set_verify ssl [ Ssl.Verify_peer ] (Some Ssl.client_verify_callback); 29 | Ssl.set_client_verify_callback_verbose true 30 | ); 31 | let sock = Unix.socket Unix.PF_INET Unix.SOCK_STREAM 0 in 32 | let sockaddr = Unix.ADDR_INET (addr, port) in 33 | (* Printf.printf "connect socket…\n%!"; *) 34 | Unix.connect sock sockaddr; 35 | (* Printf.printf "Ssl.connect socket…\n%!"; *) 36 | let sslsock = Ssl.embed_socket sock ssl in 37 | Ssl.connect sslsock; 38 | { fd = sock; ssl; sslsock } 39 | 40 | let close_socket { fd; sslsock = _; ssl = _ } = Unix.close fd 41 | let read self i len = Ssl.read self.sslsock i len 42 | let write self s i len = Ssl.write self.sslsock s i len 43 | 44 | let read_with_timeout ~timeout:_ self buf off len = 45 | try Some (Ssl.read self.sslsock buf off len) 46 | with Unix.Unix_error (Unix.ETIMEDOUT, _, _) -> None 47 | 48 | let gethostbyname name = 49 | try 50 | let entry = Unix.gethostbyname name in 51 | let addrs = Array.to_list entry.Unix.h_addr_list in 52 | addrs 53 | with Not_found -> [] 54 | 55 | let iter = List.iter 56 | let sleep d = Unix.sleepf (float d) 57 | let catch f err = try f () with e -> err e 58 | let time = Unix.gettimeofday 59 | let pick = None 60 | end 61 | 62 | include Irc_client.Make (Io_ssl) 63 | -------------------------------------------------------------------------------- /src/core/Plugin.ml: -------------------------------------------------------------------------------- 1 | (** {1 Plugins} *) 2 | 3 | open DB_utils 4 | open Lwt_infix 5 | module Log = Core.Log 6 | 7 | type json = Yojson.Safe.t 8 | 9 | type action = 10 | | Require_reload (** Require that we reload everything from on-disk state *) 11 | | Require_save (** Require that the state be saved *) 12 | 13 | type action_callback = action Signal.Send_ref.t 14 | 15 | type stateful = St : 'st stateful_ -> stateful 16 | 17 | and 'st stateful_ = { 18 | name: string; 19 | (** Namespace for storing state. Must be distinct for every plugin. *) 20 | commands: 'st -> Command.t list; 21 | (** Commands parametrized by some (mutable) state, with the ability 22 | to trigger a signal *) 23 | on_msg: 'st -> (Core.t -> Irc_message.t -> unit Lwt.t) list; 24 | (** Executed on each incoming message *) 25 | to_json: 'st -> json option; 26 | (** How to serialize (part of) the state into JSON, if need be. *) 27 | of_json : action_callback -> json option -> ('st, string) Result.result; 28 | (** How to deserialize the state. [None] is passed for a fresh 29 | initialization. *) 30 | stop: 'st -> unit Lwt.t; 31 | (** Stop the plugin. 32 | It is NOT the responsibility of this command to save the state, 33 | as the core engine will have called {!to_json} before. *) 34 | } 35 | 36 | type db_backed = { 37 | commands: DB.db -> Command.t list; 38 | (** Commands parametrized by some (mutable) state, with the ability 39 | to trigger a signal *) 40 | prepare_db: DB.db -> unit; 41 | (** Prepare database (create tables, etc.). 42 | Must be idempotent as it'll be called every time the plugin 43 | is initialized. *) 44 | on_msg: DB.db -> (Core.t -> Irc_message.t -> unit Lwt.t) list; 45 | (** Executed on each incoming message *) 46 | stop: DB.db -> unit Lwt.t; 47 | (** Stop the plugin. There is no need to close the DB connection. *) 48 | } 49 | 50 | (** A single plugin *) 51 | type t = 52 | | Stateful of stateful 53 | | Stateless of Command.t list 54 | | DB_backed of db_backed 55 | 56 | type plugin = t 57 | 58 | let of_cmd c = Stateless [ c ] 59 | 60 | let of_cmds l = 61 | if l = [] then invalid_arg "Plugin.of_cmds"; 62 | Stateless l 63 | 64 | let stateful ~name ~commands ?(on_msg = fun _ -> []) ~to_json ~of_json 65 | ?(stop = fun _ -> Lwt.return_unit) () = 66 | Stateful (St { name; on_msg; to_json; of_json; stop; commands }) 67 | 68 | let db_backed ~commands ~prepare_db ?(on_msg = fun _ -> []) 69 | ?(stop = fun _ -> Lwt.return ()) () : t = 70 | DB_backed { commands; prepare_db; on_msg; stop } 71 | 72 | (* prepare the main plugin tables, settings *) 73 | let prepare_db_ db = 74 | DB.busy_timeout db 500; 75 | DB.exec db 76 | {| 77 | CREATE TABLE IF NOT EXISTS plugins 78 | (name TEXT NOT NULL, 79 | value TEXT NOT NULL, 80 | UNIQUE (name) ON CONFLICT FAIL 81 | ); 82 | |} 83 | |> check_db_ db; 84 | Printf.printf "creating index\n"; 85 | DB.exec db 86 | {| 87 | CREATE INDEX IF NOT EXISTS plugins_idx on plugins(name); 88 | |} 89 | |> check_db_ db; 90 | () 91 | 92 | let unwrap_failwith = function 93 | | Ok x -> x 94 | | Error e -> failwith e 95 | 96 | (** {2 Collection of Plugins} *) 97 | module Set = struct 98 | type active_plugin = 99 | | Active_stateful : 'st stateful_ * 'st -> active_plugin 100 | | Active_stateless of Command.t list 101 | | Active_db_backed of db_backed 102 | 103 | type t = { 104 | config: Config.t; 105 | plugins: plugin list; 106 | actions: action Signal.t; 107 | db: DB.db; 108 | mutable active: active_plugin list; 109 | mutable commands_l: Command.t list; (* sorted by prio *) 110 | mutable on_msg_l: (Core.t -> Irc_message.t -> unit Lwt.t) list; 111 | mutable stopped: bool; 112 | } 113 | 114 | let create_db config : DB.db = 115 | let db_file = config.Config.db_file in 116 | let db = DB.db_open db_file in 117 | prepare_db_ db; 118 | db 119 | 120 | (* save JSON plugins *) 121 | let save_ db _config active = 122 | (DB.exec db "BEGIN;" |> check_db_ db; 123 | 124 | let save_plugin = function 125 | | Active_stateless _ | Active_db_backed _ -> () 126 | | Active_stateful (plugin, state) -> 127 | (* save as json into the appropriate table *) 128 | (match plugin.to_json state with 129 | | None -> () 130 | | Some j -> 131 | let@ stmt = 132 | with_stmt db 133 | {|INSERT OR REPLACE INTO plugins(name,value) VALUES(?,?);|} 134 | in 135 | DB.bind_text stmt 1 plugin.name |> check_db_ db; 136 | DB.bind_text stmt 2 (Yojson.Safe.to_string j) |> check_db_ db; 137 | DB.step stmt |> check_db_ db) 138 | in 139 | 140 | List.iter save_plugin active; 141 | DB.exec db "COMMIT;" |> check_db_ db); 142 | Lwt.return () 143 | 144 | let save (self : t) : unit Lwt.t = save_ self.db self.config self.active 145 | let commands t = t.commands_l 146 | let on_msg_l t = t.on_msg_l 147 | 148 | let load_from (db : DB.db) action_signal plugins (_config : Config.t) : 149 | (Command.t list * _ list * active_plugin list, _) result = 150 | guard_res @@ fun () -> 151 | let all_cmds = ref [] in 152 | let all_on_msg = ref [] in 153 | 154 | let init = function 155 | | Stateless cmds -> 156 | all_cmds := List.rev_append cmds !all_cmds; 157 | Active_stateless cmds 158 | | Stateful (St plugin) -> 159 | let plugin_j = 160 | let@ stmt = 161 | with_stmt db {|SELECT json(value) FROM plugins WHERE name=?|} 162 | in 163 | DB.bind_text stmt 1 plugin.name |> check_db_ db; 164 | DB.step stmt |> check_db_ db; 165 | try 166 | let j = DB.column_text stmt 1 in 167 | Some (Yojson.Safe.from_string j) 168 | with _ -> None 169 | in 170 | 171 | (match plugin.of_json action_signal plugin_j with 172 | | Error err -> 173 | failwith (spf "plugin %S failed to initialize: %s" plugin.name err) 174 | | Ok state -> 175 | all_cmds := List.rev_append (plugin.commands state) !all_cmds; 176 | all_on_msg := List.rev_append (plugin.on_msg state) !all_on_msg; 177 | 178 | Active_stateful (plugin, state)) 179 | | DB_backed plugin -> 180 | plugin.prepare_db db; 181 | all_cmds := List.rev_append (plugin.commands db) !all_cmds; 182 | all_on_msg := List.rev_append (plugin.on_msg db) !all_on_msg; 183 | 184 | Active_db_backed plugin 185 | in 186 | 187 | let active = List.map init plugins in 188 | 189 | let commands_l = List.sort Command.compare_prio @@ !all_cmds in 190 | let on_msg_l = !all_on_msg in 191 | commands_l, on_msg_l, active 192 | 193 | let reload (self : t) : _ = 194 | Log.info (fun k -> k "plugin: reload state"); 195 | let r = 196 | guard_res @@ fun () -> 197 | let commands, on_msg_l, active = 198 | load_from self.db 199 | (Signal.Send_ref.make self.actions) 200 | self.plugins self.config 201 | |> unwrap_failwith 202 | in 203 | self.commands_l <- commands; 204 | self.on_msg_l <- on_msg_l; 205 | self.active <- active 206 | in 207 | Lwt.return r 208 | 209 | let save_period = 300. 210 | 211 | (* periodic "save" *) 212 | let save_thread t : unit Lwt.t = 213 | let open Lwt.Infix in 214 | let rec loop () = 215 | Lwt_unix.sleep save_period >>= fun () -> 216 | if t.stopped then 217 | Lwt.return () 218 | else 219 | save t >>= fun _ -> loop () 220 | in 221 | loop () 222 | 223 | let create ?cmd_help:(help = true) config (plugins : plugin list) : 224 | (t, string) Result.result Lwt.t = 225 | let r = 226 | guard_res @@ fun () -> 227 | let db = create_db config in 228 | let actions = Signal.create () in 229 | let commands_l, on_msg_l, active = 230 | load_from db (Signal.Send_ref.make actions) plugins config 231 | |> unwrap_failwith 232 | in 233 | let commands_l = 234 | if help then 235 | Command.cmd_help commands_l :: commands_l 236 | else 237 | commands_l 238 | in 239 | let self = 240 | { 241 | config; 242 | db; 243 | plugins; 244 | actions; 245 | active; 246 | commands_l; 247 | on_msg_l; 248 | stopped = false; 249 | } 250 | in 251 | (* respond to actions *) 252 | Signal.on' actions (function 253 | | Require_save -> save self 254 | | Require_reload -> Lwt.map ignore (reload self)); 255 | (* save thread *) 256 | Lwt.async (fun () -> save_thread self); 257 | self 258 | in 259 | Lwt.return r 260 | 261 | let stop ?save:(save_opt = true) (self : t) : unit Lwt.t = 262 | if not self.stopped then ( 263 | Log.info (fun k -> k "stop plugins"); 264 | self.stopped <- true; 265 | let* () = 266 | if save_opt then 267 | save self 268 | else 269 | Lwt.return () 270 | in 271 | let* () = 272 | Lwt_list.iter_p 273 | (function 274 | | Active_stateless _ -> Lwt.return () 275 | | Active_db_backed p -> p.stop self.db 276 | | Active_stateful (p, st) -> p.stop st) 277 | self.active 278 | in 279 | (* close DB *) 280 | Log.info (fun k->k "closing DB"); 281 | while not (DB.db_close self.db) do 282 | () 283 | done; 284 | Log.info (fun k -> k "all plugins stopped"); 285 | Lwt.return () 286 | ) else 287 | Lwt.return () 288 | end 289 | -------------------------------------------------------------------------------- /src/core/Plugin.mli: -------------------------------------------------------------------------------- 1 | (** {1 Plugins} 2 | 3 | A plugin is a bunch of commands, and optionally some disk-backed state. 4 | It will register its commands to the core loop *) 5 | 6 | open DB_utils 7 | 8 | type json = Yojson.Safe.t 9 | 10 | type action = 11 | | Require_reload (** Require that we reload everything from on-disk state *) 12 | | Require_save (** Require that the state be saved *) 13 | 14 | type action_callback = action Signal.Send_ref.t 15 | 16 | (** A stateful plugin, using a persistent state ['st] *) 17 | type stateful = St : 'st stateful_ -> stateful 18 | 19 | and 'st stateful_ = private { 20 | name: string; 21 | (** Namespace for storing state. Must be distinct for every plugin. *) 22 | commands: 'st -> Command.t list; 23 | (** Commands parametrized by some (mutable) state, with the ability 24 | to trigger a signal *) 25 | on_msg: 'st -> (Core.t -> Irc_message.t -> unit Lwt.t) list; 26 | (** Executed on each incoming message *) 27 | to_json: 'st -> json option; 28 | (** How to serialize (part of) the state into JSON, if need be. *) 29 | of_json: action_callback -> json option -> ('st, string) Result.result; 30 | (** How to deserialize the state. [None] is passed for a fresh 31 | initialization. *) 32 | stop: 'st -> unit Lwt.t; 33 | (** Stop the plugin. 34 | It is NOT the responsibility of this command to save the state, 35 | as the core engine will have called {!to_json} before. *) 36 | } 37 | 38 | type db_backed = private { 39 | commands: DB.db -> Command.t list; 40 | (** Commands parametrized by some (mutable) state, with the ability 41 | to trigger a signal *) 42 | prepare_db: DB.db -> unit; 43 | (** Prepare database (create tables, etc.). 44 | Must be idempotent as it'll be called every time the plugin 45 | is initialized. *) 46 | on_msg: DB.db -> (Core.t -> Irc_message.t -> unit Lwt.t) list; 47 | (** Executed on each incoming message *) 48 | stop: DB.db -> unit Lwt.t; 49 | (** Stop the plugin. There is no need to close the DB connection. *) 50 | } 51 | 52 | (** A single plugin *) 53 | type t = private 54 | | Stateful of stateful 55 | | Stateless of Command.t list 56 | | DB_backed of db_backed 57 | 58 | type plugin = t 59 | 60 | val of_cmd : Command.t -> t 61 | (** Stateless plugin with 1 command. *) 62 | 63 | val of_cmds : Command.t list -> t 64 | (** Stateless plugin with several commands. 65 | @raise Invalid_argument if the list is empty *) 66 | 67 | val stateful : 68 | name:string -> 69 | commands:('st -> Command.t list) -> 70 | ?on_msg:('st -> (Core.t -> Irc_message.t -> unit Lwt.t) list) -> 71 | to_json:('st -> json option) -> 72 | of_json:(action_callback -> json option -> ('st, string) Result.result) -> 73 | ?stop:('st -> unit Lwt.t) -> 74 | unit -> 75 | t 76 | (** Make a stateful plugin using the given [name] (for prefixing 77 | its storage; this should be unique) and ways to serialize state to Json, 78 | deserialize state from Json, and building commands from the state. 79 | See {!stateful_} for more details on each field. *) 80 | 81 | val db_backed : 82 | commands:(DB.db -> Command.t list) -> 83 | prepare_db:(DB.db -> unit) -> 84 | ?on_msg:(DB.db -> (Core.t -> Irc_message.t -> unit Lwt.t) list) -> 85 | ?stop:(DB.db -> unit Lwt.t) -> 86 | unit -> 87 | t 88 | (** Make a stateful plugin that is backed by some tables in the database. 89 | See {!db_backed} for more details. 90 | @since 0.8 *) 91 | 92 | (** {2 Collection of Plugins} *) 93 | module Set : sig 94 | type t 95 | 96 | val create : 97 | ?cmd_help:bool -> Config.t -> plugin list -> (t, string) Result.result Lwt.t 98 | (** Create a collection of plugins, loading the state, initializing 99 | them. 100 | @param cmd_help if true, adds a "help" command. 101 | *) 102 | 103 | val commands : t -> Command.t list 104 | (** Corresponding list of commands *) 105 | 106 | val on_msg_l : t -> (Core.t -> Irc_message.t -> unit Lwt.t) list 107 | (** List of callbacks called on each message *) 108 | 109 | val save : t -> unit Lwt.t 110 | (** Save state to disk *) 111 | 112 | val reload : t -> (unit, string) Result.result Lwt.t 113 | (** Reload state from disk *) 114 | 115 | val stop : ?save:bool -> t -> unit Lwt.t 116 | (** Stop all plugins 117 | @param save if [true], will call {!save} first (default [true]) *) 118 | end 119 | -------------------------------------------------------------------------------- /src/core/Plugin_factoids.ml: -------------------------------------------------------------------------------- 1 | open Prelude 2 | open DB_utils 3 | module Log = Core.Log 4 | 5 | type key = string 6 | type value = StrList of string list | Int of int 7 | type factoid = { key: key; value: value } 8 | type json = Yojson.Safe.t 9 | type t = DB.db 10 | 11 | type op = 12 | | Get of key 13 | | Set of factoid 14 | | Set_force of factoid 15 | | Append of factoid 16 | | Remove of factoid 17 | | Incr of key 18 | | Decr of key 19 | 20 | let key_of_string s : key option = 21 | let s = String.trim s in 22 | if String.contains s ' ' then 23 | None 24 | else 25 | Some s 26 | 27 | let string_of_value = function 28 | | Int i -> string_of_int i 29 | | StrList l -> Prelude.string_list_to_string l 30 | 31 | let string_of_op = function 32 | | Get k -> "get " ^ k 33 | | Set { key; value } -> "set " ^ key ^ " = " ^ string_of_value value 34 | | Set_force { key; value } -> 35 | "set_force " ^ key ^ " := " ^ string_of_value value 36 | | Append { key; value } -> "append " ^ key ^ " += " ^ string_of_value value 37 | | Remove { key; value } -> "remove " ^ key ^ " -= " ^ string_of_value value 38 | | Incr k -> "incr " ^ k 39 | | Decr k -> "decr " ^ k 40 | 41 | let mk_key key = 42 | match key_of_string key with 43 | | None -> invalid_arg ("mk_key : `" ^ key ^ "`") 44 | | Some key -> key 45 | 46 | let mk_factoid key value = 47 | let key = mk_key key in 48 | let value = String.trim value in 49 | try { key; value = Int (int_of_string value) } 50 | with Failure _ -> { key; value = StrList [ value ] } 51 | 52 | (* joins the result of Re_perl.split_full back together*) 53 | let group_join list = 54 | let buf = Buffer.create 80 in 55 | let rec aux = function 56 | | `Text t :: r -> 57 | Buffer.add_string buf t; 58 | aux r 59 | | `Delim d :: r -> 60 | Buffer.add_string buf (Re.Group.get d 0); 61 | aux r 62 | | [] -> Buffer.contents buf 63 | in 64 | aux list 65 | 66 | let re_split_pat = Re.Perl.compile_pat "(^!)|([+-:]?=)|(\\+\\+)|(--)" 67 | let re_factoid = Re.Perl.compile_pat "^[ ]*[^ \n\t]+[ ]*$" 68 | 69 | let parse_op ~prefix msg : (op * string option) option = 70 | let open Option.Infix in 71 | let msg, hl = 72 | match Command.extract_hl msg with 73 | | None -> msg, None 74 | | Some (a, b) -> a, Some b 75 | in 76 | let open Option in 77 | let mk_get k = Get (mk_key k) in 78 | let mk_set k v = Set (mk_factoid k v) in 79 | let mk_set_force k v = Set_force (mk_factoid k v) in 80 | let mk_append k v = Append (mk_factoid k v) in 81 | let mk_remove k v = Remove (mk_factoid k v) in 82 | let mk_incr k = Incr (mk_key k) in 83 | let mk_decr k = Decr (mk_key k) in 84 | let is_command l = String.equal prefix (Re.Group.get l 0) in 85 | let is_factoid f = 86 | match Re.exec_opt re_factoid f with 87 | | None -> false 88 | | Some _ -> true 89 | in 90 | if String.contains msg '\x01' then 91 | None 92 | else 93 | Re.split_full re_split_pat msg 94 | |> (function 95 | | `Delim prefix :: `Text factoid :: `Delim op :: rest 96 | when is_command prefix && is_factoid factoid -> 97 | let op = Re.Group.get op 0 in 98 | let fact = group_join rest |> String.trim in 99 | let tfactoid = String.trim factoid in 100 | some (op, tfactoid, fact) 101 | | [ `Delim prefix; `Text factoid ] 102 | when is_command prefix && is_factoid factoid -> 103 | some ("", String.trim factoid, "") 104 | | _ -> None) 105 | >>= (function 106 | | "=", factoid, fact -> mk_set factoid fact |> some 107 | | "+=", factoid, fact -> mk_append factoid fact |> some 108 | | "-=", factoid, fact -> mk_remove factoid fact |> some 109 | | ":=", factoid, fact -> mk_set_force factoid fact |> some 110 | | "++", factoid, "" -> mk_incr factoid |> some 111 | | "--", factoid, "" -> mk_decr factoid |> some 112 | | "", factoid, _ -> mk_get factoid |> some 113 | | _ -> None) 114 | |> Option.map (fun x -> x, hl) 115 | 116 | let () = 117 | let test_ok s = Option.is_some (parse_op ~prefix:"!" s) in 118 | assert (test_ok "!foo2 = bar"); 119 | assert (test_ok "!foo2 = bar "); 120 | assert (test_ok "!foo2 += bar"); 121 | assert (test_ok "!foo2 += bar hello world"); 122 | assert (test_ok "!foo2 -= bar"); 123 | assert (test_ok "!foo2 -= bar hello world"); 124 | assert (test_ok "!foo ++"); 125 | assert (test_ok "!foo ++ "); 126 | assert (test_ok "!foo --"); 127 | assert (test_ok "!foo -- "); 128 | assert (test_ok "!foo"); 129 | assert (test_ok "!foo "); 130 | () 131 | 132 | exception Could_not_parse 133 | 134 | let as_str (j : json) : string = 135 | match j with 136 | | `String s -> s 137 | | _ -> raise Could_not_parse 138 | 139 | let as_value (j : json) : value = 140 | match j with 141 | | `List l -> StrList (List.map as_str l) 142 | | `Int i -> Int i 143 | | _ -> raise Could_not_parse 144 | 145 | let json_of_value = function 146 | | StrList l -> `List (List.map (fun s -> `String s) l) 147 | | Int i -> `Int i 148 | 149 | let get ?(default = StrList []) key (self : t) : value = 150 | let@ () = wrap_failwith "factoids.get" in 151 | let@ stmt = 152 | with_stmt self {| SELECT json(value) FROM factoids WHERE key=? |} 153 | in 154 | DB.bind_text stmt 1 key |> check_db_ self; 155 | DB.step stmt |> check_db_ self; 156 | try 157 | let j = DB.column_text stmt 0 in 158 | as_value @@ Yojson.Safe.from_string j 159 | with _ -> default 160 | 161 | let mem key (self : t) : bool = 162 | let@ () = wrap_failwith "factoids.mem" in 163 | let@ stmt = 164 | with_stmt self {| SELECT EXISTS (SELECT(value) FROM factoids WHERE key=?) |} 165 | in 166 | DB.bind_text stmt 1 key |> check_db_ self; 167 | DB.step stmt |> check_db_ self; 168 | DB.column_bool stmt 0 169 | 170 | let set { key; value } (self : t) : unit = 171 | let@ () = wrap_failwith "factoids.set" in 172 | let v = json_of_value value |> Yojson.Safe.to_string in 173 | let@ stmt = 174 | with_stmt self 175 | {| INSERT INTO factoids(key,value) VALUES(?1,?2) 176 | ON CONFLICT DO UPDATE SET value=?2 |} 177 | in 178 | DB.bind_text stmt 1 key |> check_db_ self; 179 | DB.bind_text stmt 2 v |> check_db_ self; 180 | DB.step stmt |> check_db_ self; 181 | () 182 | 183 | let append { key; value } (self : t) : unit = 184 | let@ () = wrap_failwith "factoids.append" in 185 | DB.exec self "BEGIN;" |> check_db_ self; 186 | let value' = 187 | match get key self, value with 188 | | Int i, Int j -> Int (i + j) 189 | | StrList [], _ -> value 190 | | StrList l, StrList l' -> StrList (l @ l') 191 | | StrList l, Int j -> StrList (string_of_int j :: l) 192 | | Int i, StrList l -> StrList (string_of_int i :: l) 193 | in 194 | set { key; value = value' } self; 195 | DB.exec self "COMMIT" |> check_db_ self; 196 | () 197 | 198 | let remove { key; value } (self : t) : unit = 199 | let@ () = wrap_failwith "factoids.remove" in 200 | let value' = 201 | match get key self, value with 202 | | Int i, Int j -> Int (i - j) 203 | | StrList [], Int j -> Int (-j) 204 | | StrList [], _ -> value 205 | | StrList l, StrList l' -> 206 | StrList (List.filter (fun s -> not (List.exists (String.equal s) l')) l) 207 | | StrList l, Int j -> 208 | StrList (List.filter (fun s -> not (String.equal (string_of_int j) s)) l) 209 | | Int _, StrList _ -> 210 | Printf.printf "Hé non, on enlève pas des strings à une valeur entière !"; 211 | value 212 | in 213 | match value' with 214 | | StrList [] | Int 0 -> 215 | let@ stmt = with_stmt self {| DELETE FROM factoids WHERE key=? |} in 216 | DB.bind_text stmt 1 key |> check_db_ self; 217 | DB.step stmt |> check_db_ self 218 | | _ -> set { key; value = value' } self 219 | 220 | let as_int v = 221 | match v with 222 | | Int i -> Some i 223 | | StrList [ s ] -> (try Some (int_of_string s) with _ -> None) 224 | | _ -> None 225 | 226 | let incr key (self : t) : int option = 227 | let value = get key ~default:(Int 0) self in 228 | match as_int value with 229 | | Some i -> 230 | let count = i + 1 in 231 | set { key; value = Int count } self; 232 | Some count 233 | | None -> None 234 | 235 | let decr key (self : t) : int option = 236 | let value = get key ~default:(Int 0) self in 237 | match as_int value with 238 | | Some i -> 239 | let count = i - 1 in 240 | set { key; value = Int count } self; 241 | Some count 242 | | None -> None 243 | 244 | let search tokens (self : t) : string list = 245 | let tokens = List.map CCString.lowercase_ascii tokens in 246 | (* list pairs [key, value] that match all the given tokens? *) 247 | let check_str s tok = CCString.mem ~sub:tok (CCString.lowercase_ascii s) in 248 | let check_int i tok = String.equal tok (string_of_int i) in 249 | let mk_pair k v = Printf.sprintf "%s -> %s" k v in 250 | let tok_matches key value : string list = 251 | match value with 252 | | Int i -> 253 | if List.for_all (fun tok -> check_str key tok || check_int i tok) tokens 254 | then 255 | [ mk_pair key (string_of_int i) ] 256 | else 257 | [] 258 | | StrList l -> 259 | CCList.filter_map 260 | (fun sub -> 261 | if 262 | List.for_all 263 | (fun tok -> check_str key tok || check_str sub tok) 264 | tokens 265 | then 266 | Some (mk_pair key sub) 267 | else 268 | None) 269 | l 270 | in 271 | 272 | let@ stmt = with_stmt self {| SELECT key, value FROM factoids; |} in 273 | let rc, l = 274 | DB.fold stmt ~init:[] ~f:(fun choices row -> 275 | match row with 276 | | [| DB.Data.TEXT key; DB.Data.TEXT value |] -> 277 | let value = Yojson.Safe.from_string value |> as_value in 278 | List.rev_append (tok_matches key value) choices 279 | | _ -> choices) 280 | in 281 | check_db_ self rc; 282 | l 283 | 284 | let random (self : t) : string = 285 | let@ () = wrap_failwith "factoids.random" in 286 | match 287 | let@ stmt = 288 | with_stmt self {| SELECT key FROM factoids ORDER BY random() LIMIT 1 |} 289 | in 290 | DB.step stmt |> check_db_ self; 291 | try Some (DB.column_text stmt 0) with _ -> None 292 | with 293 | | None -> "" 294 | | Some key -> 295 | Log.debug (fun k -> k "random: key is %S" key); 296 | let value = get key self in 297 | let msg_val = 298 | match value with 299 | | StrList [] -> assert false 300 | | StrList l -> Rand_distrib.uniform l |> Rand_distrib.run 301 | | Int i -> string_of_int i 302 | in 303 | spf "!%s: %s" key msg_val 304 | 305 | (* returns a help message that suggest keys that are close to [k] 306 | by edit distance, and the number of such keys *) 307 | let find_close_keys (k : key) (self : t) : string * int = 308 | let l = 309 | let@ stmt = with_stmt self {| SELECT key FROM factoids |} in 310 | let rc, l = 311 | DB.fold stmt ~init:[] ~f:(fun keys row -> 312 | match row with 313 | | [| DB.Data.TEXT key |] -> 314 | let d = Prelude.edit_distance key k in 315 | if d <= 2 then 316 | (d, key) :: keys 317 | else 318 | keys 319 | | _ -> keys) 320 | in 321 | check_db_ self rc; 322 | l |> List.sort CCOrd.poly |> List.map snd 323 | in 324 | let l = 325 | if List.length l > 5 then 326 | CCList.take 5 l @ [ "…" ] 327 | else 328 | l 329 | in 330 | let res = 331 | match l with 332 | | [] -> "" 333 | | [ x ] -> Printf.sprintf "did you mean %s?" x 334 | | _ -> 335 | CCFormat.sprintf "did you mean one of %a@]?" CCFormat.(Dump.list string) l 336 | in 337 | res, List.length l 338 | 339 | (* operations *) 340 | 341 | let max_card_for_force = ref 5 342 | 343 | let set_max_cardinal_for_force x = 344 | assert (x >= 2); 345 | max_card_for_force := x 346 | 347 | (* maximum size of returned lists *) 348 | let list_size_limit = 4 349 | 350 | let limit_list l = 351 | let n = List.length l in 352 | if n > list_size_limit then 353 | CCList.take list_size_limit l @ [ "…" ] 354 | else 355 | l 356 | 357 | let insert_noresult = function 358 | | [] -> [ "nothing found!" ] 359 | | l -> l 360 | 361 | (* tokenize message into search tokens *) 362 | let search_tokenize s = String.trim s |> Re.split (Re.Perl.compile_pat "[ \t]+") 363 | 364 | let cmd_search (self : t) = 365 | Command.make_simple_l ~descr:"search in factoids" ~cmd:"search" ~prio:10 366 | (fun _ s -> 367 | let tokens = search_tokenize s in 368 | search tokens self |> limit_list |> insert_noresult |> Lwt.return) 369 | 370 | let cmd_search_all (self : t) = 371 | Command.make_simple_query_l 372 | ~descr:"search all matches in factoids (reply in pv)" ~cmd:"search_all" 373 | ~prio:10 (fun _ s -> 374 | Lwt.return 375 | @@ 376 | let tokens = search_tokenize s in 377 | search tokens self |> insert_noresult |> fun l -> 378 | if List.length l > 5 then 379 | [ String.concat " | " l ] 380 | else 381 | l) 382 | 383 | let cmd_see (self : t) = 384 | Command.make_simple_l ~descr:"see a factoid's content" ~cmd:"see" ~prio:10 385 | (fun _ s -> 386 | let v = get (mk_key s) self in 387 | let msg = 388 | match v with 389 | | Int i -> [ string_of_int i ] 390 | | StrList [] -> [ "not found." ] 391 | | StrList l -> limit_list l 392 | in 393 | Lwt.return msg) 394 | 395 | let cmd_see_all (self : t) = 396 | Command.make_simple_query_l ~descr:"see all of a factoid's content (in pv)" 397 | ~cmd:"see_all" ~prio:10 (fun _ s -> 398 | let v = get (mk_key s) self in 399 | let msg = 400 | match v with 401 | | Int i -> [ string_of_int i ] 402 | | StrList [] -> [ "not found." ] 403 | | StrList l -> 404 | if List.length l > 5 then 405 | [ String.concat " | " l ] 406 | else 407 | l 408 | in 409 | Lwt.return msg) 410 | 411 | let cmd_random (self : t) = 412 | Command.make_simple ~descr:"random factoid" ~cmd:"random" ~prio:10 (fun _ _ -> 413 | let msg = random self in 414 | Lwt.return @@ Some msg) 415 | 416 | let cmd_factoids (self : t) = 417 | let reply ~prefix (module C : Core.S) msg = 418 | let target = Core.reply_to msg in 419 | let matched x = Command.Cmd_match x in 420 | let add_hl hl line = 421 | match hl with 422 | | None -> line 423 | | Some x -> x ^ ": " ^ line 424 | in 425 | let reply_value ~hl (v : value) = 426 | match v with 427 | | Int i -> 428 | C.send_privmsg ~target ~message:(string_of_int i |> add_hl hl) 429 | |> matched 430 | | StrList [] -> matched @@ Lwt.return () 431 | | StrList [ message ] -> 432 | C.send_privmsg ~target ~message:(add_hl hl message) |> matched 433 | | StrList l -> 434 | let message = Rand_distrib.uniform l |> Rand_distrib.run |> add_hl hl in 435 | C.send_privmsg ~target ~message |> matched 436 | and count_update_message (k : key) = function 437 | | None -> Lwt.return () 438 | | Some count -> 439 | C.send_privmsg ~target 440 | ~message:(Printf.sprintf "%s : %d" (k :> string) count) 441 | in 442 | let op = parse_op ~prefix msg.Core.message in 443 | Option.iter 444 | (fun (c, _) -> 445 | Log.debug (fun k -> k "factoids: parsed command `%s`" (string_of_op c))) 446 | op; 447 | match op with 448 | | Some (Get k, hl) -> 449 | (match get k self with 450 | | StrList [] -> 451 | let help_msg, n = find_close_keys k self in 452 | (* probably a typo for this key *) 453 | if n > 0 then 454 | C.send_privmsg ~target ~message:help_msg |> matched 455 | else 456 | Command.Cmd_skip 457 | | v -> 458 | Log.debug (fun k -> k "factoids: get returned %s" (string_of_value v)); 459 | reply_value ~hl v) 460 | | Some (Set f, _) -> 461 | if mem f.key self then 462 | C.talk ~target Talk.Err |> matched 463 | else ( 464 | set f self; 465 | C.talk ~target Talk.Ack |> matched 466 | ) 467 | | Some (Set_force f, _) -> 468 | let l = get f.key self in 469 | (match l with 470 | | StrList l when List.length l >= !max_card_for_force -> 471 | C.talk ~target Talk.Err |> matched 472 | | _ -> 473 | set f self; 474 | C.talk ~target Talk.Ack |> matched) 475 | | Some (Append f, _) -> 476 | append f self; 477 | C.talk ~target Talk.Ack |> matched 478 | | Some (Remove f, _) -> 479 | remove f self; 480 | C.talk ~target Talk.Ack |> matched 481 | | Some (Incr k, _) -> 482 | let count = incr k self in 483 | count_update_message k count |> matched 484 | | Some (Decr k, _) -> 485 | let count = decr k self in 486 | count_update_message k count |> matched 487 | | None -> Command.Cmd_skip 488 | in 489 | Command.make ~name:"factoids" ~prio:80 reply 490 | ~descr: 491 | "factoids, triggered by the following commands:\n\n\ 492 | \ - `!foo` will retrieve one of the factoids associated with `foo`, \ 493 | if any\n\ 494 | \ - `!foo = bar` maps `foo` to `bar`, unless `foo` is mapped yet\n\ 495 | \ (in which case it fails)\n\ 496 | \ - `!foo += bar` adds `bar` to the mappings of `foo`, or adds \ 497 | integer value bar to the integer value foo\n\ 498 | \ - `!foo -= bar` removes `bar` from the mappings of `foo`, or \ 499 | subtracts bar to the integer value foo\n\ 500 | \ - `!foo++` adds 1 to the integer value foo\n\ 501 | \ - `!foo--` subtracts 1 to the integer value foo\n\ 502 | \ - `!foo := bar` maps `foo` to `bar` even if `foo` is already mapped\n\ 503 | \ - `!search term` looks up `term` in the database\n\ 504 | \ - `!search_all` looks up all terms in the database\n\ 505 | \ " 506 | 507 | let commands (state : t) : Command.t list = 508 | [ 509 | cmd_factoids state; 510 | cmd_search state; 511 | cmd_search_all state; 512 | cmd_see state; 513 | cmd_see_all state; 514 | cmd_random state; 515 | ] 516 | 517 | let prepare_db db = 518 | DB.exec db 519 | {| 520 | CREATE TABLE IF NOT EXISTS 521 | factoids ( 522 | key TEXT NOT NULL, 523 | value TEXT NOT NULL, 524 | UNIQUE (key) ON CONFLICT FAIL 525 | ) STRICT; 526 | |} 527 | |> check_db_ db; 528 | 529 | DB.exec db 530 | {| 531 | CREATE INDEX IF NOT EXISTS factoids_idx on factoids(key); 532 | |} 533 | |> check_db_ db; 534 | () 535 | 536 | let plugin : Plugin.t = Plugin.db_backed ~prepare_db ~commands () 537 | -------------------------------------------------------------------------------- /src/core/Plugin_factoids.mli: -------------------------------------------------------------------------------- 1 | type key = private string (* utf8 *) 2 | 3 | type value = StrList of string list | Int of int 4 | type factoid = { key: key; value: value } 5 | type t 6 | 7 | val key_of_string : string -> key option 8 | 9 | type op = 10 | | Get of key 11 | | Set of factoid 12 | | Set_force of factoid 13 | | Append of factoid 14 | | Remove of factoid 15 | | Incr of key 16 | | Decr of key 17 | 18 | val parse_op : prefix:string -> string -> (op * string option) option 19 | (** op + hilight *) 20 | 21 | val string_of_value : value -> string 22 | val string_of_op : op -> string 23 | val plugin : Plugin.t 24 | 25 | val set_max_cardinal_for_force : int -> unit 26 | (** [set_max_cardinal_for_force n] prevents [Set_force] for keys 27 | with more than [n] factoids, to not lose too much data. *) 28 | -------------------------------------------------------------------------------- /src/core/Plugin_history.ml: -------------------------------------------------------------------------------- 1 | (** {1 History plugin} *) 2 | 3 | (** Keep the last [n] lines of history on a chan, and give them to newcomers 4 | that ask for them *) 5 | 6 | (* time, nick, msg *) 7 | type line = { time: float; nick_: string; msg: string } 8 | 9 | type t = { 10 | actions: Plugin.action_callback; 11 | hist: line Queue.t; 12 | size: int; (* max size of [hist] *) 13 | default_len: int; (* default length of history in query *) 14 | } 15 | 16 | let on_msg state _ m = 17 | match Core.privmsg_of_msg m with 18 | | None -> Lwt.return () 19 | | Some { Core.to_; _ } when not (Core.is_chan to_) -> 20 | Lwt.return () (* ignore private messages *) 21 | | Some { Core.nick; to_ = _; message } -> 22 | let time = Unix.gettimeofday () in 23 | let line = { time; nick_ = nick; msg = message } in 24 | (* pop oldest item if the queue is full *) 25 | if Queue.length state.hist >= state.size then ignore (Queue.pop state.hist); 26 | Queue.push line state.hist; 27 | Lwt.return () 28 | 29 | (* list of lines in history *) 30 | let reply_history state n : string list = 31 | assert (n > 0); 32 | Queue.fold 33 | (fun acc line -> 34 | let time = 35 | Ptime.of_float_s line.time |> Option.get_or "invalid timestamp" 36 | in 37 | let line' = 38 | Printf.sprintf "[%s] %s: %s" 39 | (Ptime.to_rfc3339 ~space:false time) 40 | line.nick_ line.msg 41 | in 42 | line' :: acc) 43 | [] state.hist 44 | |> CCList.take n (* take the last [n] messages *) 45 | |> List.rev 46 | 47 | let cmd_history st : _ = 48 | Command.make_simple_query_l 49 | ~descr: 50 | (Printf.sprintf "give back lines of history in query (max %d)" st.size) 51 | ~prio:10 ~cmd:"history" (fun _ msg -> 52 | let msg = String.trim msg in 53 | if msg = "" then 54 | Lwt.return @@ reply_history st st.default_len 55 | else 56 | Lwt.return 57 | (* parse the number of lines *) 58 | (try 59 | let n = int_of_string msg in 60 | if n > 0 then 61 | reply_history st n 62 | else 63 | [ Talk.select Talk.Err ] 64 | with _ -> [ Talk.select Talk.Err ])) 65 | 66 | let plugin ?(default_len = 10) ?(n = 150) () = 67 | Plugin.stateful ~name:"history" 68 | ~of_json:(fun actions _ -> 69 | Ok { actions; size = n; default_len; hist = Queue.create () }) 70 | ~to_json:(fun _ -> None) 71 | ~on_msg:(fun state -> [ on_msg state ]) 72 | ~stop:(fun _ -> Lwt.return ()) 73 | ~commands:(fun st -> [ cmd_history st ]) 74 | () 75 | -------------------------------------------------------------------------------- /src/core/Plugin_history.mli: -------------------------------------------------------------------------------- 1 | 2 | (** {1 History plugin} *) 3 | 4 | (** Keep the last [n] lines of history on a chan, and give them to newcomers 5 | that ask for them *) 6 | 7 | val plugin : ?default_len:int -> ?n:int -> unit -> Plugin.t 8 | (** plugin for storing [n] lines of history and giving them back in query 9 | to people who ask. 10 | @param n the number of lines to retain internally 11 | @param default_len the number of lines to display by default, when 12 | replying to message "!history" *) 13 | -------------------------------------------------------------------------------- /src/core/Plugin_social.ml: -------------------------------------------------------------------------------- 1 | open DB_utils 2 | module J = Yojson.Safe.Util 3 | 4 | type json = Yojson.Safe.t 5 | 6 | type to_tell = { 7 | from: string; 8 | on_channel: string; 9 | msg: string; 10 | tell_after: float option; (** optional; not before this deadline (UTC) *) 11 | } 12 | 13 | (* Data for contacts *) 14 | type contact = { 15 | last_seen: float; 16 | to_tell: to_tell list; 17 | ignore_user: bool; (* user does not turn up in searches etc. *) 18 | } 19 | 20 | let equal_contact : contact -> contact -> bool = CCEqual.poly 21 | 22 | (* we only need second precision here *) 23 | let now = Unix.time 24 | 25 | exception Bad_json of string 26 | 27 | let contact_of_json (json : json) : (contact, string) result = 28 | let member k = 29 | match J.member k json with 30 | | `Null -> raise (Bad_json (spf "member not found: %S" k)) 31 | | v -> v 32 | in 33 | try 34 | { 35 | last_seen = member "lastSeen" |> J.to_float; 36 | to_tell = 37 | member "to_tell" 38 | |> J.convert_each (fun j -> 39 | match J.convert_each J.to_string j with 40 | | [ from; on_channel; msg ] -> 41 | { from; on_channel; msg; tell_after = None } 42 | | [ from; on_channel; msg; tell_after ] -> 43 | let tell_after = Some (float_of_string tell_after) in 44 | { from; on_channel; msg; tell_after } 45 | | _ -> 46 | raise 47 | (Bad_json 48 | (spf "bad `tell` object: %s" (Yojson.Safe.to_string j)))); 49 | ignore_user = 50 | (match J.member "ignore_user" json with 51 | | `Null -> false 52 | | v -> J.to_bool_option v |> Option.value ~default:false); 53 | } 54 | |> fun x -> Ok x 55 | with 56 | | Bad_json s -> Error s 57 | | J.Type_error (_, _) -> assert false 58 | 59 | let json_of_contact (c : contact) : json = 60 | `Assoc 61 | [ 62 | "lastSeen", `Float c.last_seen; 63 | ( "to_tell", 64 | `List 65 | (List.map 66 | (fun { from; on_channel; msg; tell_after } -> 67 | let last = 68 | match tell_after with 69 | | None -> [] 70 | | Some f -> [ `String (string_of_float f) ] 71 | in 72 | `List ([ `String from; `String on_channel; `String msg ] @ last)) 73 | c.to_tell) ); 74 | "ignore_user", `Bool c.ignore_user; 75 | ] 76 | 77 | (* Contacts db *) 78 | 79 | type t = DB.db 80 | 81 | let prepare_db (self : t) : unit = 82 | DB.exec self 83 | {| CREATE TABLE IF NOT EXISTS 84 | social(name TEXT NOT NULL, 85 | value TEXT NOT NULL, 86 | UNIQUE (name) ON CONFLICT FAIL 87 | ) STRICT; 88 | |} 89 | |> check_db_ self; 90 | DB.exec self {| CREATE INDEX IF NOT EXISTS idx_social on social(name); |} 91 | |> check_db_ self; 92 | () 93 | 94 | let is_contact (self : t) nick : bool = 95 | let@ () = wrap_failwith "social.is_contact" in 96 | let@ stmt = 97 | with_stmt self {| SELECT EXISTS (SELECT * from social WHERE name=?) |} 98 | in 99 | DB.bind_text stmt 1 nick |> check_db_ self; 100 | DB.step stmt |> check_db_ self; 101 | DB.column_bool stmt 0 102 | 103 | let set_data (self : t) nick (contact : contact) : unit = 104 | let nick = String.lowercase_ascii nick in 105 | let j = contact |> json_of_contact |> Yojson.Safe.to_string in 106 | let@ () = wrap_failwith "social.set_data" in 107 | let@ stmt = 108 | with_stmt self 109 | {| INSERT INTO social(name, value) 110 | VALUES(?1,?2) 111 | ON CONFLICT(name) 112 | DO UPDATE SET value=?2 |} 113 | in 114 | DB.bind_text stmt 1 nick |> check_db_ self; 115 | DB.bind_text stmt 2 j |> check_db_ self; 116 | DB.step stmt |> check_db_ self 117 | 118 | let new_contact (self : t) nick : contact = 119 | let nick = String.lowercase_ascii nick in 120 | let d = { last_seen = now (); to_tell = []; ignore_user = false } in 121 | set_data self nick d; 122 | d 123 | 124 | let data (self : t) nick : contact option = 125 | let nick = String.lowercase_ascii nick in 126 | let@ () = wrap_failwith "social.data" in 127 | if is_contact self nick then ( 128 | let@ stmt = with_stmt self {| SELECT value FROM social WHERE name=? |} in 129 | DB.bind_text stmt 1 nick |> check_db_ self; 130 | DB.step stmt |> check_db_ self; 131 | match 132 | let s = DB.column_text stmt 0 in 133 | s, s |> Yojson.Safe.from_string |> contact_of_json 134 | with 135 | | _, Ok c -> Some c 136 | | s, Error err -> failwith (spf "invalid contact %S: %s" s err) 137 | | exception _ -> failwith (spf "cannot access contact %S" nick) 138 | ) else 139 | None 140 | 141 | let ignored (self : t) : string list = 142 | let@ () = wrap_failwith "social.ignored" in 143 | let@ stmt = 144 | with_stmt self 145 | {| SELECT name FROM social 146 | WHERE json_extract(value, '$.ignore_user') = true |} 147 | in 148 | let rc, l = 149 | DB.fold stmt ~init:[] ~f:(fun acc row -> 150 | match row with 151 | | [| DB.Data.TEXT r |] -> r :: acc 152 | | _ -> acc) 153 | in 154 | check_db_ self rc; 155 | l 156 | 157 | let last_talk (self : t) ~n : (string * float) list = 158 | let@ () = wrap_failwith "social.ignored" in 159 | let@ stmt = 160 | with_stmt self 161 | {| SELECT name, json_extract(value, '$.lastSeen') as lastSeen FROM social 162 | ORDER BY lastSeen DESC 163 | LIMIT ?|} 164 | in 165 | DB.bind_int stmt 1 n |> check_db_ self; 166 | let rc, l = 167 | DB.fold stmt ~init:[] ~f:(fun acc row -> 168 | match row with 169 | | [| DB.Data.TEXT r; DB.Data.FLOAT t |] -> (r, t) :: acc 170 | | _ -> acc) 171 | in 172 | check_db_ self rc; 173 | l 174 | 175 | let data_or_insert (self : t) nick : contact = 176 | match data self nick with 177 | | Some c -> c 178 | | None -> new_contact self nick 179 | 180 | let update_data (self : t) nick ~f : contact = 181 | let@ () = wrap_failwith "social.update-data" in 182 | let d = data_or_insert self nick in 183 | let d' = f d in 184 | if not (equal_contact d d') then set_data self nick d'; 185 | d' 186 | 187 | let update_data' self nick ~f : unit = 188 | ignore (update_data self nick ~f : contact) 189 | 190 | let split_2 ~msg re s = 191 | let a = Re.split re s in 192 | match a with 193 | | x :: y -> x, String.concat " " y 194 | | _ -> raise (Command.Fail msg) 195 | 196 | let split_3 ~msg re s = 197 | let a = Re.split re s in 198 | match a with 199 | | x :: y :: tail -> x, y, String.concat " " tail 200 | | _ -> raise (Command.Fail msg) 201 | 202 | let cmd_tell_inner ~at (self : t) = 203 | Command.make_simple 204 | ~descr: 205 | ("ask the bot to transmit a message to someone absent\n" 206 | ^ 207 | if at then 208 | "format: " 209 | else 210 | "format: ") 211 | ~prio:10 212 | ~cmd: 213 | (if at then 214 | "tell_at" 215 | else 216 | "tell") 217 | (fun msg s -> 218 | let nick = msg.Core.nick in 219 | let target = Core.reply_to msg in 220 | let s = String.trim s in 221 | try 222 | let dest, msg, tell_after = 223 | if at then ( 224 | let d, m, t = 225 | split_3 ~msg:"tell_at: expected " 226 | (Re.Perl.compile_pat "[ \t]+") 227 | s 228 | in 229 | let t = 230 | match 231 | Ptime.of_rfc3339 ~strict:false t |> Ptime.rfc3339_error_to_msg 232 | with 233 | | Ok (t, _, _) -> Ptime.to_float_s t 234 | | Error (`Msg msg) -> failwith (spf "invalid timestamp: %s" msg) 235 | in 236 | d, m, Some t 237 | ) else ( 238 | let d, m = 239 | split_2 ~msg:"tell: expected " 240 | (Re.Perl.compile_pat "[ \t]+") 241 | s 242 | in 243 | d, m, None 244 | ) 245 | in 246 | update_data' self dest ~f:(fun state -> 247 | { 248 | state with 249 | to_tell = 250 | { from = nick; on_channel = target; msg; tell_after } 251 | :: state.to_tell; 252 | }); 253 | Lwt.return_some (Talk.select Talk.Ack) 254 | with 255 | | Command.Fail _ as e -> raise e 256 | | e -> raise (Command.Fail ("tell: " ^ Printexc.to_string e))) 257 | 258 | let cmd_tell = cmd_tell_inner ~at:false 259 | let cmd_tell_at = cmd_tell_inner ~at:true 260 | 261 | (* human readable display of date *) 262 | let print_diff (f : float) : string = 263 | let spf = Printf.sprintf in 264 | let s = mod_float f 60. |> int_of_float in 265 | let m = mod_float (f /. 60.) 60. |> int_of_float in 266 | let h = mod_float (f /. 3600.) 24. |> int_of_float in 267 | let days = mod_float (f /. (3600. *. 24.)) 365. |> int_of_float in 268 | let years = f /. (365. *. 3600. *. 24.) |> int_of_float in 269 | [ 270 | (if years > 0 then 271 | [ spf "%d years" years ] 272 | else 273 | []); 274 | (if days > 0 then 275 | [ spf "%d days" days ] 276 | else 277 | []); 278 | (if h > 0 then 279 | [ spf "%d hours" h ] 280 | else 281 | []); 282 | (if m > 0 then 283 | [ spf "%d minutes" m ] 284 | else 285 | []); 286 | [ spf "%d seconds" s ]; 287 | ] 288 | |> List.flatten |> String.concat ", " 289 | 290 | let create_message_for_user now user last = 291 | let diff = now -. last in 292 | CCFormat.sprintf "seen %s last: %s ago" user (print_diff diff) 293 | 294 | let cmd_seen (self : t) = 295 | Command.make_simple_l 296 | ~descr:"ask for the last time someone talked on this chan" ~prio:10 297 | ~cmd:"seen" (fun _msg s -> 298 | try 299 | let now = now () in 300 | let nick = CCString.trim s |> String.lowercase_ascii in 301 | Logs.debug ~src:Core.logs_src (fun k -> k "query: seen `%s`" nick); 302 | match data self nick with 303 | | Some c -> Lwt.return [ create_message_for_user now nick c.last_seen ] 304 | | None -> Lwt.return [] 305 | with e -> raise (Command.Fail ("seen: " ^ Printexc.to_string e))) 306 | 307 | let cmd_last (self : t) = 308 | Command.make_simple_l 309 | ~descr:"ask for the last n people talking on this chan (default: n=3)" 310 | ~prio:10 ~cmd:"last" (fun _msg s -> 311 | try 312 | let default_n = 3 in 313 | let dest = String.trim s in 314 | 315 | let top_n = 316 | try 317 | match int_of_string dest with 318 | | x when x > 0 -> x 319 | | _ -> default_n 320 | with Failure _ -> default_n 321 | in 322 | 323 | Logs.debug ~src:Core.logs_src (fun k -> k "query: last `%n`" top_n); 324 | 325 | let now = now () in 326 | let l = last_talk self ~n:top_n in 327 | let l = CCList.map (fun (n, t) -> create_message_for_user now n t) l in 328 | Lwt.return l 329 | with e -> raise (Command.Fail ("last_seen: " ^ Printexc.to_string e))) 330 | 331 | let cmd_ignore_template ~cmd prefix_stem ignore (self : t) = 332 | Command.make_simple ~descr:(cmd ^ " nick") ~prio:10 ~cmd (fun _ s -> 333 | try 334 | let dest = String.trim s in 335 | Logs.debug ~src:Core.logs_src (fun k -> k "query: ignore `%s`" dest); 336 | if String.equal dest "" then 337 | Lwt.return None 338 | else ( 339 | let contact = data_or_insert self dest in 340 | let msg = 341 | if Bool.equal contact.ignore_user ignore then 342 | CCFormat.sprintf "already %sing %s" prefix_stem dest 343 | |> Option.some 344 | else ( 345 | set_data self dest { contact with ignore_user = ignore }; 346 | CCFormat.sprintf "%sing %s" prefix_stem dest |> Option.some 347 | ) 348 | in 349 | Lwt.return msg 350 | ) 351 | with e -> raise (Command.Fail (cmd ^ ": " ^ Printexc.to_string e))) 352 | 353 | let cmd_ignore = cmd_ignore_template ~cmd:"ignore" "ignor" true 354 | let cmd_unignore = cmd_ignore_template ~cmd:"unignore" "unignor" false 355 | 356 | let cmd_ignore_list (self : t) = 357 | Command.make_simple_l ~descr:"add nick to list of ignored people" ~prio:10 358 | ~cmd:"ignore_list" (fun _ _ -> 359 | try 360 | Logs.debug ~src:Core.logs_src (fun k -> k "query: ignore_list"); 361 | let ignored = ignored self in 362 | let msg = 363 | if CCList.is_empty ignored then 364 | [ "no one ignored!" ] 365 | else 366 | "ignoring:" :: ignored 367 | in 368 | Lwt.return msg 369 | with e -> raise (Command.Fail ("ignore_list: " ^ Printexc.to_string e))) 370 | 371 | (* callback to update state, notify users of their messages, etc. *) 372 | let on_message (self : t) (module C : Core.S) msg : _ Lwt.t = 373 | let module Msg = Irc_message in 374 | let nick, channel = 375 | match msg.Msg.command with 376 | | Msg.JOIN (_, _) | Msg.PRIVMSG (_, _) -> 377 | let msg = 378 | Core.privmsg_of_msg msg |> Option.get_or "message parsing error" 379 | in 380 | ( Some msg.nick, 381 | if Core.is_chan msg.to_ then 382 | Some msg.to_ 383 | else 384 | None ) 385 | | Msg.NICK newnick -> Some newnick, None 386 | | _ -> None, None 387 | in 388 | (* trigger [tell] messages *) 389 | match nick with 390 | | None -> Lwt.return () 391 | | Some nick -> 392 | (* update [lastSeen] *) 393 | let now = now () in 394 | let contact = 395 | update_data self nick ~f:(fun st -> { st with last_seen = now }) 396 | in 397 | let to_tell, remaining = 398 | contact.to_tell 399 | |> List.partition (fun t -> 400 | match t.tell_after, channel with 401 | | _, None -> false 402 | | None, _ -> true 403 | | Some f, Some chan -> 404 | (* delay expired, and it was on the same channel *) 405 | CCFloat.(now > f) && String.equal t.on_channel chan) 406 | in 407 | if not (CCList.is_empty to_tell) then 408 | set_data self nick { contact with to_tell = remaining }; 409 | Lwt_list.iter_p 410 | (fun { from = author; on_channel; msg = m; _ } -> 411 | C.send_notice ~target:on_channel 412 | ~message:(Printf.sprintf "%s: (from %s): %s" nick author m)) 413 | (List.rev to_tell) 414 | 415 | let plugin = 416 | let commands self = 417 | [ 418 | cmd_tell self; 419 | cmd_tell_at self; 420 | cmd_seen self; 421 | cmd_last self; 422 | cmd_ignore self; 423 | cmd_unignore self; 424 | cmd_ignore_list self; 425 | ] 426 | in 427 | Plugin.db_backed ~commands ~prepare_db 428 | ~on_msg:(fun st -> [ on_message st ]) 429 | () 430 | -------------------------------------------------------------------------------- /src/core/Plugin_social.mli: -------------------------------------------------------------------------------- 1 | 2 | (** Social: keeps a register "nick -> informations" up-to-date. 3 | The type {!contact} can be extended to store new informations. 4 | 5 | One must then extend the function {!contacts_of_json} 6 | and {!json_of_contact} to handle the new fields (and deal with the 7 | case where we import old JSON values that don't have the new 8 | fields, e.g. by using a default value). 9 | 10 | The data stored in the contacts base are usually automatically updated 11 | by callbacks defined in {!Social} (thanks to {!Signal.on}). 12 | *) 13 | 14 | type to_tell = { 15 | from: string; 16 | on_channel: string; 17 | msg: string; 18 | tell_after: float option; (** optional; not before this deadline (UTC) *) 19 | } 20 | 21 | (* Data for contacts *) 22 | type contact = { 23 | last_seen: float; 24 | to_tell: to_tell list; 25 | ignore_user: bool; 26 | } 27 | 28 | val plugin : Plugin.t 29 | -------------------------------------------------------------------------------- /src/core/Plugin_state.ml: -------------------------------------------------------------------------------- 1 | (** {1 Manage state} *) 2 | 3 | open Lwt_infix 4 | 5 | type t = { actions: Plugin.action_callback } 6 | 7 | let cmd_reload st = 8 | Command.make_simple ~descr:"reload state from disk" ~prio:10 ~cmd:"reload" 9 | (fun _ _ -> 10 | let+ () = Signal.Send_ref.send st.actions Plugin.Require_reload in 11 | Some (Talk.select Talk.Ack)) 12 | 13 | let cmd_save st = 14 | Command.make_simple ~descr:"save state to disk" ~prio:10 ~cmd:"save" 15 | (fun _ _ -> 16 | let+ () = Signal.Send_ref.send st.actions Plugin.Require_save in 17 | Some (Talk.select Talk.Ack)) 18 | 19 | let plugin = 20 | Plugin.stateful ~name:"state" 21 | ~of_json:(fun actions _ -> Ok { actions }) 22 | ~to_json:(fun _ -> None) 23 | ~stop:(fun _ -> Lwt.return ()) 24 | ~commands:(fun st -> [ cmd_reload st; cmd_save st ]) 25 | () 26 | -------------------------------------------------------------------------------- /src/core/Plugin_state.mli: -------------------------------------------------------------------------------- 1 | 2 | (** {1 Manage state} *) 3 | 4 | (** This module provides commands for reloading/saving state on disk. 5 | 6 | TODO: credentials *) 7 | 8 | val plugin : Plugin.t 9 | -------------------------------------------------------------------------------- /src/core/Plugin_vote.ml: -------------------------------------------------------------------------------- 1 | open Result 2 | open Lwt_infix 3 | 4 | (* TODO add proper lib *) 5 | module Time = struct 6 | type t = float 7 | 8 | let minutes x : t = float_of_int x *. 60. 9 | let as_mins x = int_of_float @@ (x /. 60.) 10 | 11 | let display_mins x = 12 | match as_mins x with 13 | | 0 -> "less than 1 minute" 14 | | 1 -> "one minute" 15 | | n -> Printf.sprintf "%d minutes" n 16 | 17 | let now = Unix.gettimeofday 18 | end 19 | 20 | module Vote = struct 21 | type vote = For | Against 22 | 23 | type t = { 24 | purpose: string; (* short description *) 25 | expire: float; (* time at which the poll expires *) 26 | status: (string, vote) Hashtbl.t; (* nick -> vote *) 27 | mutable quorum: int option; (* how many votes needed to reach quorum? *) 28 | } 29 | 30 | let start ?quorum ?(duration = Time.minutes 30) purpose = 31 | { 32 | purpose; 33 | status = Hashtbl.create 10; 34 | expire = Time.(now () +. duration); 35 | quorum; 36 | } 37 | 38 | let add_vote t nick vote = 39 | match CCHashtbl.get t.status nick with 40 | | None -> Hashtbl.add t.status nick vote 41 | | Some old_vote when old_vote = vote -> () 42 | | _ -> Hashtbl.replace t.status nick vote 43 | 44 | (* results for one poll *) 45 | type result = { for_: int; against: int } 46 | 47 | let count_votes t : result = 48 | Hashtbl.fold 49 | (fun _ vote r -> 50 | match vote with 51 | | For -> { r with for_ = r.for_ + 1 } 52 | | Against -> { r with against = r.against + 1 }) 53 | t.status { for_ = 0; against = 0 } 54 | 55 | let vote_status t nick = 56 | try Some (Hashtbl.find t.status nick) with Not_found -> None 57 | 58 | let show_status t = 59 | let r = count_votes t in 60 | Printf.sprintf "expressed %d / for %d / against %d (expires in %s)" 61 | (Hashtbl.length t.status) r.for_ r.against 62 | Time.(display_mins @@ (t.expire -. now ())) 63 | 64 | let missing_votes t : int option = 65 | match t.quorum with 66 | | None -> None 67 | | Some n -> Some (max 0 (n - Hashtbl.length t.status)) 68 | 69 | let expired now { expire; _ } = expire < now 70 | 71 | let is_complete t = 72 | (match missing_votes t with 73 | | Some 0 -> true 74 | | _ -> false) 75 | || expired (Time.now ()) t 76 | 77 | let get_winner t = 78 | let r = count_votes t in 79 | if r.for_ > r.against then 80 | Some For 81 | else if r.against < r.for_ then 82 | Some Against 83 | else 84 | None 85 | 86 | let string_of_vote = function 87 | | For -> "for" 88 | | Against -> "against" 89 | 90 | let vote_of_string = function 91 | | "for" -> Ok For 92 | | "against" -> Ok Against 93 | | _ -> Error "wrong vote (expected 'for' or 'against')" 94 | end 95 | 96 | type poll = { purpose: string; creator: string; vote: Vote.t } 97 | type state = { polls: (string, poll) Hashtbl.t; mutable stop: bool } 98 | 99 | let max_polls_per_nick = 1 100 | let max_polls = 5 101 | 102 | let nb_polls_per_nick polls nick = 103 | Hashtbl.fold 104 | (fun _ { creator; _ } count -> 105 | if creator = nick then 106 | count + 1 107 | else 108 | count) 109 | polls 0 110 | 111 | let show_status name { creator; vote; _ } = 112 | Printf.sprintf "Poll %s (created by %s) : %s" name creator 113 | (Vote.show_status vote) 114 | 115 | let create_poll polls nick name purpose = 116 | match Hashtbl.length polls with 117 | | cur_len when cur_len >= max_polls -> 118 | Error 119 | "cannot create a new poll: max number has been reached, please delete \ 120 | one before proceeding" 121 | | _ -> 122 | (match nb_polls_per_nick polls nick with 123 | | cur_polls when cur_polls >= max_polls_per_nick -> 124 | Error 125 | (Printf.sprintf 126 | "cannot create a new poll: max number by user has been reached: %d, \ 127 | please delete one before proceeding" 128 | max_polls_per_nick) 129 | | _ -> 130 | (match CCHashtbl.get polls name with 131 | | Some poll -> 132 | Error 133 | (Printf.sprintf "a poll already exists with this name: %s" 134 | (show_status name poll)) 135 | | None -> 136 | let poll = 137 | { purpose = name; creator = nick; vote = Vote.start purpose } 138 | in 139 | Hashtbl.add polls name poll; 140 | Ok 141 | (Some 142 | (Printf.sprintf "Poll %s successfully created! %s" name 143 | (show_status name poll))))) 144 | 145 | let vote polls nick name vote = 146 | match CCHashtbl.get polls name with 147 | | None -> Error (Printf.sprintf "no poll called '%s'" name) 148 | | Some poll -> 149 | (match Vote.vote_of_string vote with 150 | | Error _ as e -> e 151 | | Ok vote -> 152 | Vote.add_vote poll.vote nick vote; 153 | (match Vote.is_complete poll.vote with 154 | | true -> 155 | Hashtbl.remove polls name; 156 | Ok 157 | (Some 158 | (Printf.sprintf "Poll time has ended!: The final result is %s" 159 | (Option.value ~default:"draw" 160 | @@ Option.map Vote.string_of_vote 161 | @@ Vote.get_winner poll.vote))) 162 | | _ -> Ok (Some (Vote.show_status poll.vote)))) 163 | 164 | let show_vote polls name nick = 165 | match CCHashtbl.get polls name with 166 | | None -> Error (Printf.sprintf "no active poll named '%s'" name) 167 | | Some poll -> 168 | let vote = 169 | Option.value ~default:"draw" 170 | @@ Option.map Vote.string_of_vote 171 | @@ Vote.vote_status poll.vote nick 172 | in 173 | Ok (Some (Printf.sprintf "%s is %s %s" nick vote name)) 174 | 175 | let vote_status polls name = 176 | match CCHashtbl.get polls name with 177 | | None -> Error (Printf.sprintf "no active poll named '%s'" name) 178 | | Some poll -> Ok (Some (show_status name poll)) 179 | 180 | let rec collector (st : state) : _ Lwt.t = 181 | let now = Time.now () in 182 | Hashtbl.iter 183 | (fun name { vote; _ } -> 184 | if Vote.expired now vote then Hashtbl.remove st.polls name) 185 | st.polls; 186 | Lwt_unix.sleep (Time.minutes 1) >>= fun () -> collector st 187 | 188 | let help = 189 | "!vote show : display current vote of for \n\ 190 | !vote start : create new poll\n\ 191 | !vote status : display current status of \n\ 192 | !vote for : vote for the given \n\ 193 | !vote against : vote against the given \n" 194 | 195 | let reply (self : state) msg s : _ Lwt.t = 196 | let message_usage = 197 | "Please use `!vote for VOTE_NAME` or `!vote against VOTE_NAME` to vote; or \ 198 | start a new vote with `!vote start VOTE_NAME`. (run !help vote for the \ 199 | complete list of commands)" 200 | in 201 | let reply_res = function 202 | | Error msg -> 203 | let message = Printf.sprintf "%s: %s" Talk.(select Err) msg in 204 | Lwt.return @@ Some message 205 | | Ok x -> Lwt.return x 206 | in 207 | match Stringext.split ~max:3 (String.trim s) ~on:' ' with 208 | | "show" :: name :: nick :: _ -> show_vote self.polls name nick |> reply_res 209 | | "start" :: name :: purpose -> 210 | create_poll self.polls msg.Core.nick name 211 | (match purpose with 212 | | [] -> "" 213 | | purpose :: _ -> purpose) 214 | |> reply_res 215 | | "status" :: name :: _ -> vote_status self.polls name |> reply_res 216 | | (("for" | "against") as v) :: name :: _ -> 217 | vote self.polls msg.Core.nick name v |> reply_res 218 | | [ (("show" | "start" | "status" | "for" | "against") as v) ] -> 219 | Error 220 | (Printf.sprintf 221 | "this command is missing the vote name. Please specify one as in \ 222 | `vote %sVOTE_NAME" 223 | v) 224 | |> reply_res 225 | | _ -> Error ("invalid command. " ^ message_usage) |> reply_res 226 | 227 | let cmd_vote state : Command.t = 228 | Command.make_simple 229 | ~descr:("vote system for yes/no questions\n" ^ help) 230 | ~cmd:"vote" ~prio:10 (reply state) 231 | 232 | let of_json _ _ : (state, _) result = 233 | let polls = { stop = false; polls = Hashtbl.create 10 } in 234 | Lwt.async (fun () -> collector polls); 235 | Ok polls 236 | 237 | let plugin = 238 | Plugin.stateful ~name:"vote" 239 | ~to_json:(fun _ -> None) 240 | ~of_json 241 | ~commands:(fun state -> [ cmd_vote state ]) 242 | ~stop:(fun st -> 243 | st.stop <- true; 244 | Lwt.return ()) 245 | () 246 | -------------------------------------------------------------------------------- /src/core/Plugin_vote.mli: -------------------------------------------------------------------------------- 1 | 2 | (** {1 Vote System} *) 3 | 4 | (** This module provides a plugin for starting polls, voting on them, 5 | and collecting the results. *) 6 | 7 | val plugin : Plugin.t 8 | -------------------------------------------------------------------------------- /src/core/Prelude.ml: -------------------------------------------------------------------------------- 1 | (** {1 helpers} *) 2 | 3 | let string_opt_to_string = function 4 | | None -> "None" 5 | | Some s -> Printf.sprintf "Some %s" s 6 | 7 | let string_list_to_string string_list = 8 | Printf.sprintf "[%s]" (String.concat "; " string_list) 9 | 10 | let get_nick h = CCString.Split.left_exn ~by:"!" h |> fst 11 | 12 | let ( |? ) o x = 13 | match o with 14 | | None -> x 15 | | Some y -> y 16 | 17 | let contains s (re : Re.re) = Re.execp re s 18 | 19 | let re_match2 f r s = 20 | match Re.exec_opt r s with 21 | | None -> None 22 | | Some g -> f (Re.Group.get g 1) (Re.Group.get g 2) |> Option.some 23 | 24 | let re_match1 f r s = 25 | match Re.exec_opt r s with 26 | | None -> None 27 | | Some g -> f (Re.Group.get g 1) |> Option.some 28 | 29 | let re_match0 x r s = 30 | if contains s r then 31 | Some x 32 | else 33 | None 34 | 35 | (* from containers 1.0 *) 36 | let edit_distance s1 s2 = 37 | if String.length s1 = 0 then 38 | String.length s2 39 | else if String.length s2 = 0 then 40 | String.length s1 41 | else if s1 = s2 then 42 | 0 43 | else ( 44 | (* distance vectors (v0=previous, v1=current) *) 45 | let v0 = Array.make (String.length s2 + 1) 0 in 46 | let v1 = Array.make (String.length s2 + 1) 0 in 47 | (* initialize v0: v0(i) = A(0)(i) = delete i chars from t *) 48 | for i = 0 to String.length s2 do 49 | v0.(i) <- i 50 | done; 51 | (* main loop for the bottom up dynamic algorithm *) 52 | for i = 0 to String.length s1 - 1 do 53 | (* first edit distance is the deletion of i+1 elements from s *) 54 | v1.(0) <- i + 1; 55 | 56 | (* try add/delete/replace operations *) 57 | for j = 0 to String.length s2 - 1 do 58 | let cost = 59 | if Char.compare (String.get s1 i) (String.get s2 j) = 0 then 60 | 0 61 | else 62 | 1 63 | in 64 | v1.(j + 1) <- min (v1.(j) + 1) (min (v0.(j + 1) + 1) (v0.(j) + cost)) 65 | done; 66 | 67 | (* copy v1 into v0 for next iteration *) 68 | Array.blit v1 0 v0 0 (String.length s2 + 1) 69 | done; 70 | v1.(String.length s2) 71 | ) 72 | 73 | module StrMap = CCMap.Make (String) 74 | 75 | (** {2 Random Distribution} *) 76 | module Rand_distrib = struct 77 | type 'a t = ('a * float) list 78 | 79 | let return x = [ x, 1. ] 80 | 81 | let rec add x p = function 82 | | [] -> [ x, p ] 83 | | (y, q) :: t -> 84 | if x = y then 85 | (y, q +. p) :: t 86 | else 87 | (y, q) :: add x p t 88 | 89 | let rec ( >>= ) (a : 'a t) (b : 'a -> 'b t) : 'b t = 90 | match a with 91 | | [] -> [] 92 | | (x, t) :: tl -> 93 | List.fold_left (fun pre (c, u) -> add c (u *. t) pre) (tl >>= b) (b x) 94 | 95 | let binjoin a b = List.map (fun (x, d) -> x, d /. 2.) (a @ b) 96 | 97 | let join l = 98 | let flatten = List.fold_left ( @ ) [] in 99 | let n = List.length l in 100 | flatten (List.map (List.map (fun (x, d) -> x, d /. float_of_int n)) l) 101 | 102 | let uniform l = join (List.map return l) 103 | let filter p l = List.filter (fun (a, _) -> p a) l 104 | 105 | let top d = 106 | let m = List.fold_left (fun b (_, u) -> max b u) 0. d in 107 | List.filter (fun (_, u) -> u = m) d 108 | 109 | let bot d = 110 | let m = List.fold_left (fun b (_, u) -> min b u) 2. d in 111 | List.filter (fun (_, u) -> u = m) d 112 | 113 | let () = Random.self_init () 114 | 115 | let run x = 116 | let rec aux f = function 117 | | [] -> assert false 118 | | [ (v, _) ] -> v 119 | | (v, h) :: t -> 120 | if f <= h then 121 | v 122 | else 123 | aux (f -. h) t 124 | in 125 | aux (Random.float 1.) x 126 | 127 | let normalize l = 128 | let i = List.fold_left (fun a (_, b) -> a +. b) 0. l in 129 | List.map (fun (a, k) -> a, k /. i) l 130 | end 131 | 132 | let random_l l = Rand_distrib.(run @@ uniform l) 133 | -------------------------------------------------------------------------------- /src/core/Prelude.mli: -------------------------------------------------------------------------------- 1 | (** {1 helpers} *) 2 | 3 | val string_opt_to_string : string option -> string 4 | 5 | val string_list_to_string : string list -> string 6 | 7 | val get_nick : string -> string 8 | 9 | val (|?) : 'a option -> 'a -> 'a 10 | (** [o |? x] is [y] if [o=Some y], [x] otherwise *) 11 | 12 | val contains : string -> Re.re -> bool 13 | 14 | val re_match2 : (string -> string -> 'a) -> Re.re -> string -> 'a option 15 | 16 | val re_match1 : (string -> 'a) -> Re.re -> string -> 'a option 17 | 18 | val re_match0 : 'a -> Re.re -> string -> 'a option 19 | 20 | val edit_distance : string -> string -> int 21 | 22 | module StrMap : CCMap.S with type key = string 23 | 24 | (** {2 Random Distribution} *) 25 | module Rand_distrib : sig 26 | type 'a t = ('a * float) list 27 | 28 | val return : 'a -> 'a t 29 | val ( >>= ) : 'a t -> ('a -> 'b t) -> 'b t 30 | 31 | val add : 'a -> float -> 'a t -> 'a t 32 | val binjoin : 'a t -> 'a t -> 'a t 33 | val join : 'a t list -> 'a t 34 | 35 | val uniform : 'a list -> 'a t 36 | val filter : ('a -> bool) -> 'a t -> 'a t 37 | val top : 'a t -> 'a t 38 | val bot : 'a t -> 'a t 39 | val normalize : 'a t -> 'a t 40 | 41 | val run : 'a t -> 'a 42 | (** Pick a value in the given distribution *) 43 | end 44 | 45 | val random_l : 'a list -> 'a 46 | (** Random choice in list, shortcut for {!Rand_distrib} *) 47 | -------------------------------------------------------------------------------- /src/core/Run_main.ml: -------------------------------------------------------------------------------- 1 | open Lwt_infix 2 | 3 | let main ?cmd_help ?(on_init = ignore) conf all : unit Lwt.t = 4 | let init_or_err (core : Core.t) : _ result Lwt.t = 5 | let (module C) = core in 6 | (* setup plugins *) 7 | Logs.info ~src:Core.logs_src (fun k -> k "creating plugins…"); 8 | let* plugins = Plugin.Set.create ?cmd_help conf all in 9 | Logs.info ~src:Core.logs_src (fun k -> 10 | k "plugins initialized (ok: %b)…" (Result.is_ok plugins)); 11 | let plugins = unwrap_result_failwith plugins in 12 | (* connect to chan *) 13 | let* () = Lwt_unix.sleep 2. in 14 | Logs.info ~src:Core.logs_src (fun k -> k "joining channels…"); 15 | let* () = 16 | Lwt_list.iter_s (fun c -> C.send_join ~channel:c) conf.Config.channels 17 | in 18 | Logs.info ~src:Core.logs_src (fun k -> k "run %d plugins" (List.length all)); 19 | (* log incoming messages, apply commands to them *) 20 | let prefix = conf.Config.prefix in 21 | Signal.on' C.messages (fun msg -> 22 | let cmds = Plugin.Set.commands plugins in 23 | let on_msg_l = Plugin.Set.on_msg_l plugins in 24 | let* () = Lwt_list.iter_s (fun f -> f core msg) on_msg_l in 25 | match Core.privmsg_of_msg msg with 26 | | None -> Lwt.return () 27 | | Some msg -> Command.run ~prefix core cmds msg); 28 | Lwt.return @@ Ok () 29 | in 30 | (* error-logging wraper *) 31 | let init core : unit Lwt.t = 32 | Lwt.catch 33 | (fun () -> 34 | on_init core; 35 | let+ x = init_or_err core in 36 | match x with 37 | | Ok () -> () 38 | | Error (Failure msg) -> 39 | Logs.err ~src:Core.logs_src (fun k -> k "error in init: %s" msg) 40 | | Error e -> 41 | let msg = Printexc.to_string e in 42 | Logs.err ~src:Core.logs_src (fun k -> k "error in init: %s" msg)) 43 | (fun e -> 44 | let msg = Printexc.to_string e in 45 | Logs.err ~src:Core.logs_src (fun k -> k "error in init: %s" msg); 46 | Lwt.return ()) 47 | in 48 | Core.run conf ~init () 49 | -------------------------------------------------------------------------------- /src/core/Run_main.mli: -------------------------------------------------------------------------------- 1 | (** {1 Simple Runner} *) 2 | 3 | val main : 4 | ?cmd_help:bool -> 5 | ?on_init:(Core.t -> unit) -> 6 | Config.t -> 7 | Plugin.t list -> 8 | unit Lwt.t 9 | (** Easy wrapper for a bot that takes some configuration 10 | (including the connection options, such as the network 11 | and channel to join) and a list of plugins, and 12 | runs the (re)connection loop with the list 13 | of plugins. 14 | 15 | @param cmd_help if true, will add a "help" command with the [Config.t] prefix field. 16 | Default is [true]. 17 | 18 | Main should look like this: 19 | {[ 20 | let main () = 21 | let module C = Calculon in 22 | let config = C.Config.parse C.Config.default Sys.argv in 23 | C.Run_main.main config plugins |> Lwt_main.run 24 | ]} 25 | *) 26 | -------------------------------------------------------------------------------- /src/core/Signal.ml: -------------------------------------------------------------------------------- 1 | (** {1 Basic signal} *) 2 | 3 | open Lwt_infix 4 | 5 | type handler_response = ContinueListening | StopListening 6 | 7 | type 'a t = { 8 | mutable n: int; (* how many handlers? *) 9 | mutable handlers: ('a -> handler_response Lwt.t) array; 10 | mutable alive: keepalive; (* keep some signal alive *) 11 | } 12 | (** Signal of type 'a *) 13 | 14 | and keepalive = Keep : 'a t -> keepalive | NotAlive : keepalive 15 | 16 | type 'a signal = 'a t 17 | 18 | let _exn_handler = ref (fun _ -> ()) 19 | let nop_handler _x = Lwt.return ContinueListening 20 | 21 | let create () = 22 | let s = { n = 0; handlers = Array.make 3 nop_handler; alive = NotAlive } in 23 | s 24 | 25 | (* remove handler at index i *) 26 | let remove s i = 27 | assert (s.n > 0 && i >= 0); 28 | if i < s.n - 1 (* erase handler with the last one *) then 29 | s.handlers.(i) <- s.handlers.(s.n - 1); 30 | s.handlers.(s.n - 1) <- nop_handler; 31 | (* free handler *) 32 | s.n <- s.n - 1; 33 | () 34 | 35 | let send s x = 36 | let rec loop i = 37 | Lwt.catch 38 | (fun () -> 39 | s.handlers.(i) x >>= function 40 | | ContinueListening -> Lwt.return false 41 | | StopListening -> Lwt.return true) 42 | (fun exn -> 43 | !_exn_handler exn; 44 | Lwt.return false (* be conservative, keep... *)) 45 | >>= fun b -> 46 | if b then ( 47 | remove s i; 48 | (* i-th handler is done, remove it *) 49 | loop i 50 | ) else if i < s.n then 51 | loop (i + 1) 52 | else 53 | Lwt.return () 54 | in 55 | loop 0 56 | 57 | let on s f = 58 | (* resize handlers if needed *) 59 | if s.n = Array.length s.handlers then ( 60 | let handlers = Array.make (s.n + 4) nop_handler in 61 | Array.blit s.handlers 0 handlers 0 s.n; 62 | s.handlers <- handlers 63 | ); 64 | s.handlers.(s.n) <- f; 65 | s.n <- s.n + 1 66 | 67 | let on' s f = on s (fun x -> f x >>= fun _ -> Lwt.return ContinueListening) 68 | let once s f = on s (fun x -> f x >>= fun _ -> Lwt.return StopListening) 69 | 70 | let propagate a b = 71 | on a (fun x -> send b x >>= fun () -> Lwt.return ContinueListening) 72 | 73 | (** {2 Combinators} *) 74 | 75 | let map signal f = 76 | let signal' = create () in 77 | (* weak ref *) 78 | let r = Weak.create 1 in 79 | Weak.set r 0 (Some signal'); 80 | on signal (fun x -> 81 | match Weak.get r 0 with 82 | | None -> Lwt.return StopListening 83 | | Some signal' -> 84 | send signal' (f x) >>= fun () -> Lwt.return ContinueListening); 85 | signal'.alive <- Keep signal; 86 | signal' 87 | 88 | let filter signal p = 89 | let signal' = create () in 90 | (* weak ref *) 91 | let r = Weak.create 1 in 92 | Weak.set r 0 (Some signal'); 93 | on signal (fun x -> 94 | match Weak.get r 0 with 95 | | None -> Lwt.return StopListening 96 | | Some signal' -> 97 | (if p x then 98 | send signal' x 99 | else 100 | Lwt.return ()) 101 | >>= fun () -> Lwt.return ContinueListening); 102 | signal'.alive <- Keep signal; 103 | signal' 104 | 105 | let filter_map signal f = 106 | let signal' = create () in 107 | (* weak ref *) 108 | let r = Weak.create 1 in 109 | Weak.set r 0 (Some signal'); 110 | on signal (fun x -> 111 | match Weak.get r 0 with 112 | | None -> Lwt.return StopListening 113 | | Some signal' -> 114 | (match f x with 115 | | None -> Lwt.return () 116 | | Some x -> send signal' x) 117 | >>= fun () -> Lwt.return ContinueListening); 118 | signal'.alive <- Keep signal; 119 | signal' 120 | 121 | let set_exn_handler h = _exn_handler := h 122 | 123 | (** {2 Send-only View} *) 124 | 125 | (** Can be used only for sending *) 126 | 127 | module Send_ref = struct 128 | type 'a t = 'a signal 129 | 130 | let make s = s 131 | let send = send 132 | end 133 | -------------------------------------------------------------------------------- /src/core/Signal.mli: -------------------------------------------------------------------------------- 1 | (** {1 Basic signal} *) 2 | 3 | type 'a t 4 | (** Signal of type 'a *) 5 | 6 | type 'a signal = 'a t 7 | 8 | val create : unit -> 'a t 9 | (** New signal *) 10 | 11 | val send : 'a t -> 'a -> unit Lwt.t 12 | (** Trigger the signal *) 13 | 14 | type handler_response = ContinueListening | StopListening 15 | 16 | val on : 'a t -> ('a -> handler_response Lwt.t) -> unit 17 | (** Register a handler to the signal; the handler returns [ContinueListening] 18 | if it wants to continue being notified, [StopListening] otherwise *) 19 | 20 | val on' : 'a t -> ('a -> 'b Lwt.t) -> unit 21 | 22 | val once : 'a t -> ('a -> 'b Lwt.t) -> unit 23 | (** Register a handler to be called only once *) 24 | 25 | val propagate : 'a t -> 'a t -> unit 26 | (** [propagate a b] propagates all values of [a] into [b]. Cycles 27 | are not detected. *) 28 | 29 | (** {2 Combinators} *) 30 | 31 | val map : 'a t -> ('a -> 'b) -> 'b t 32 | val filter : 'a t -> ('a -> bool) -> 'a t 33 | val filter_map : 'a t -> ('a -> 'b option) -> 'b t 34 | 35 | val set_exn_handler : (exn -> unit) -> unit 36 | (** Set the handler that is called upon an exception in 37 | a Signal. The default handler does nothing. 38 | If the handler raises an exception, it is not caught! *) 39 | 40 | (** {2 Send-only View} *) 41 | 42 | (** Can be used only for sending *) 43 | 44 | module Send_ref : sig 45 | type 'a t 46 | 47 | val make : 'a signal -> 'a t 48 | val send : 'a t -> 'a -> unit Lwt.t 49 | end 50 | -------------------------------------------------------------------------------- /src/core/Talk.ml: -------------------------------------------------------------------------------- 1 | 2 | (* À étendre *) 3 | 4 | type t = 5 | | Ack 6 | | Err 7 | 8 | let ack = [ 9 | "OK."; 10 | "done."; 11 | "Success" 12 | ] 13 | 14 | let error = [ 15 | "oops"; 16 | "uh"; 17 | "hmm"; 18 | "Failure"; 19 | ] 20 | 21 | let talk_base = function 22 | | Ack -> ack 23 | | Err -> error 24 | 25 | let select ty = talk_base ty |> Prelude.random_l 26 | -------------------------------------------------------------------------------- /src/core/Talk.mli: -------------------------------------------------------------------------------- 1 | 2 | (** {1 Basic Messages} 3 | 4 | These messages are typical replies to user-issued commands, with a bit of 5 | randomness to diminish the monotony *) 6 | 7 | type t = 8 | | Ack (** Ok *) 9 | | Err (** Error occurred *) 10 | 11 | val select : t -> string 12 | (** A particular representation of this message *) 13 | -------------------------------------------------------------------------------- /src/core/common/calculon_common.ml: -------------------------------------------------------------------------------- 1 | let spf = Printf.sprintf 2 | let[@inline] ( let@ ) f x = f x 3 | let id x = x 4 | 5 | module Option = struct 6 | include Option 7 | 8 | let get_or msg = function 9 | | Some x -> x 10 | | None -> failwith msg 11 | 12 | let get_or_lazy default = function 13 | | Some x -> x 14 | | None -> default () 15 | 16 | module Infix = struct 17 | let ( let+ ) x f = Option.map f x 18 | let ( let* ) = Option.bind 19 | let ( >|= ) x f = Option.map f x 20 | let ( >>= ) = Option.bind 21 | 22 | let ( and+ ) x y = 23 | match x, y with 24 | | None, _ | _, None -> None 25 | | Some x, Some y -> Some (x, y) 26 | end 27 | end 28 | 29 | let unwrap_result_failwith = function 30 | | Ok x -> x 31 | | Error msg -> failwith msg 32 | 33 | let wrap_failwith ctx f = 34 | try f () 35 | with exn -> 36 | let err = 37 | match exn with 38 | | Failure e -> spf "%s\n%s" e ctx 39 | | e -> spf "%s\n%s" (Printexc.to_string e) ctx 40 | in 41 | Logs.err (fun k -> k "fail: %s" err); 42 | failwith err 43 | 44 | let guard_res ?(ctx = "") f : _ result = 45 | try Ok (f ()) with 46 | | Failure e -> Error e 47 | | e -> Error (ctx ^ Printexc.to_string e) 48 | 49 | module Lwt_infix = struct 50 | let ( let* ) = Lwt.bind 51 | let ( let+ ) x f = Lwt.map f x 52 | let ( and+ ) = Lwt.both 53 | let ( and* ) = ( and+ ) 54 | let ( >|= ) x f = Lwt.map f x 55 | let ( >>= ) = Lwt.bind 56 | end 57 | -------------------------------------------------------------------------------- /src/core/common/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name calculon_common) 3 | (libraries logs lwt) 4 | (public_name calculon.common)) 5 | -------------------------------------------------------------------------------- /src/core/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name calculon) 3 | (public_name calculon) 4 | (flags :standard -warn-error -a+8 -open Calculon_common) 5 | (libraries containers yojson re re.perl logs sqlite3 calculon.common ptime 6 | lwt lwt.unix irc-client-lwt irc-client-lwt-ssl irc-client stringext unix 7 | threads.posix)) 8 | -------------------------------------------------------------------------------- /src/demo/demo_bot.ml: -------------------------------------------------------------------------------- 1 | module C = Calculon 2 | 3 | let plugins : C.Plugin.t list = 4 | [ 5 | C.Plugin_social.plugin; 6 | C.Plugin_factoids.plugin; 7 | C.Plugin_state.plugin; 8 | C.Plugin_history.plugin ~n:40 (); 9 | ] 10 | 11 | let config = 12 | { 13 | C.Config.default with 14 | C.Config.server = "irc.libera.chat"; 15 | port = 6697; 16 | username = "test_bot"; 17 | realname = "test_bot"; 18 | nick = "test_bot"; 19 | log_level = Logs.Info; 20 | tls = true; 21 | channels = [ "##test1234" ]; 22 | } 23 | 24 | let () = 25 | Logs.set_reporter (Logs.format_reporter ~dst:Format.err_formatter ()); 26 | try 27 | (* update with CLI parameters *) 28 | let config = C.Config.parse config Sys.argv in 29 | Logs.set_level ~all:true (Some config.C.Config.log_level); 30 | C.Run_main.main config plugins |> Lwt_main.run 31 | with 32 | | Arg.Help msg -> print_endline msg 33 | | Arg.Bad msg -> 34 | prerr_endline msg; 35 | exit 1 36 | -------------------------------------------------------------------------------- /src/demo/dune: -------------------------------------------------------------------------------- 1 | 2 | (executable 3 | (name demo_bot) 4 | (modes native) 5 | (libraries calculon calculon.extras) 6 | ) 7 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (env 2 | (_ 3 | (flags :standard -w -69-70 -warn-error -a+8))) 4 | -------------------------------------------------------------------------------- /src/extras/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name calculon_extras) 4 | (optional) 5 | (public_name calculon.extras) 6 | (libraries calculon re re.posix iter unix)) 7 | -------------------------------------------------------------------------------- /src/extras/irclog.ml: -------------------------------------------------------------------------------- 1 | 2 | (** {1 Small Parser for IRC Logs} *) 3 | 4 | type 'a sequence = ('a -> unit) -> unit 5 | 6 | type log_record = { 7 | author: string; 8 | time: string; 9 | msg: string; 10 | } 11 | 12 | let string_of_record r = 13 | Printf.sprintf "{author=%s, time=%s, msg=%s}" r.author r.time r.msg 14 | 15 | let pp_record out r = 16 | Format.fprintf out "{author=%s, time=%s, msg=%s}" r.author r.time r.msg 17 | 18 | let re_irssi = Re.Posix.re "([0-9:-]*)<([^>]*)> (.*)" |> Re.compile 19 | let re_weechat = Re.Posix.re "([0-9 :-]*)\t([^>]*)>\t(.*)" |> Re.compile 20 | 21 | type fmt = 22 | | Irssi 23 | | Weechat 24 | 25 | let re_of_fmt = function 26 | | Irssi -> re_irssi 27 | | Weechat -> re_weechat 28 | 29 | let fmt_of_string = function 30 | | "irssi" -> Irssi 31 | | "weechat" -> Weechat 32 | | s -> invalid_arg ("unknown Irclog.fmt: " ^ s) 33 | 34 | let string_of_fmt = function 35 | | Irssi -> "irssi" 36 | | Weechat -> "weechat" 37 | 38 | let fmt_l = List.map string_of_fmt [Irssi; Weechat] 39 | 40 | (* read lines *) 41 | let rec seq_lines_ ic yield = 42 | match try Some (input_line ic) with End_of_file -> None with 43 | | Some s -> yield s; seq_lines_ ic yield 44 | | None -> () 45 | 46 | let norm_author s = 47 | if s="" then s 48 | else match s.[0] with 49 | | '+' | '@' -> String.sub s 1 (String.length s-1) 50 | | _ -> s 51 | 52 | let parse_record fmt s = 53 | let re = re_of_fmt fmt in 54 | begin match Re.exec_opt re s with 55 | | None -> None 56 | | Some g -> 57 | let time = Re.Group.get g 1 |> String.trim in 58 | let author = Re.Group.get g 2 |> String.trim |> norm_author in 59 | let msg = Re.Group.get g 3 in 60 | (* check if this line is useless *) 61 | begin match author, fmt with 62 | | ("--" | "<--" | "-->"), Weechat -> None (* join/part *) 63 | | _ -> Some {author; time; msg} 64 | end 65 | end 66 | 67 | let seq_record_ fmt ic yield = 68 | seq_lines_ ic 69 | (fun l -> match parse_record fmt l with 70 | | None -> () 71 | | Some r -> yield r) 72 | 73 | let iter_file fmt file yield = 74 | CCIO.with_in file (fun ic -> seq_record_ fmt ic yield) 75 | 76 | let rec seq_files_ dir yield = 77 | let d = Unix.opendir dir in 78 | CCFun.finally1 79 | ~h:(fun () -> Unix.closedir d) 80 | (fun d -> 81 | let rec aux () = match try Some (Unix.readdir d) with End_of_file -> None with 82 | | Some s -> 83 | let abs_s = Filename.concat dir s in 84 | begin 85 | if s = "." || s = ".." then () 86 | else if Sys.is_directory abs_s 87 | then seq_files_ abs_s yield 88 | else yield abs_s 89 | end; 90 | aux () 91 | | None -> () 92 | in 93 | aux ()) 94 | d 95 | 96 | let iter_dir fmt dir yield = 97 | seq_files_ dir 98 | (fun file -> 99 | CCIO.with_in file 100 | (fun ic -> seq_record_ fmt ic (fun x -> yield (file,x)))) 101 | 102 | let iter_file_or_dir fmt s = 103 | if Sys.is_directory s 104 | then 105 | seq_files_ s 106 | |> Iter.flat_map (iter_file fmt) 107 | else iter_file fmt s 108 | 109 | -------------------------------------------------------------------------------- /src/extras/irclog.mli: -------------------------------------------------------------------------------- 1 | 2 | (** {1 Small Parser for IRC Logs} *) 3 | 4 | type 'a sequence = ('a -> unit) -> unit 5 | 6 | (** One message in a IRC log *) 7 | type log_record = { 8 | author: string; 9 | time: string; 10 | msg: string; 11 | } 12 | 13 | val re_irssi : Re.re 14 | (** Irssi logs *) 15 | 16 | val re_weechat : Re.re 17 | (** Weechat logs *) 18 | 19 | type fmt = 20 | | Irssi 21 | | Weechat 22 | 23 | val fmt_of_string : string -> fmt 24 | val string_of_fmt : fmt -> string 25 | val fmt_l : string list 26 | 27 | val parse_record : fmt -> string -> log_record option 28 | (** Parse one line of log *) 29 | 30 | val string_of_record : log_record -> string 31 | (** Print record *) 32 | 33 | val pp_record : log_record CCFormat.printer 34 | 35 | val iter_file : fmt -> string -> log_record sequence 36 | 37 | val iter_dir : fmt -> string -> (string * log_record) sequence 38 | 39 | val iter_file_or_dir : fmt -> string -> log_record sequence 40 | 41 | val norm_author : string -> string 42 | (** Normalize author's name *) 43 | -------------------------------------------------------------------------------- /src/tools/dune: -------------------------------------------------------------------------------- 1 | 2 | (executable 3 | (name migrate_state) 4 | (public_name calculon-migrate-state) 5 | (libraries sqlite3 calculon yojson) 6 | (package calculon)) 7 | -------------------------------------------------------------------------------- /src/tools/migrate_state.ml: -------------------------------------------------------------------------------- 1 | 2 | module DB = Sqlite3 3 | module J = Yojson.Safe 4 | 5 | let help= 6 | {|migrate_state state.json [opt]* 7 | 8 | This tool migrates a state.json file into a database (sqlite) file 9 | that Calculon now uses.|} 10 | 11 | let () = 12 | let file = ref "" in 13 | let db = ref Calculon.Config.default.db_file in 14 | let opts = [ 15 | "-db", Arg.Set_string db, " DB file"; 16 | ] |> Arg.align in 17 | Arg.parse opts (fun f -> file := f) help; 18 | if !file="" then failwith "please provide a file"; 19 | Printf.printf "migrating %S to %S\n" !file !db; 20 | 21 | let db = DB.db_open !db in 22 | 23 | let[@inline] check_db_ rc = 24 | if DB.Rc.is_success rc then () 25 | else failwith (Printf.sprintf "DB error: %s %s" (DB.Rc.to_string rc) (DB.errmsg db)) 26 | in 27 | 28 | Printf.printf "creating table\n"; 29 | DB.exec db {| 30 | CREATE TABLE IF NOT EXISTS plugins 31 | (name TEXT NOT NULL, 32 | value TEXT NOT NULL, 33 | UNIQUE (name) ON CONFLICT FAIL 34 | ) STRICT; 35 | |} |> check_db_; 36 | 37 | Printf.printf "creating index\n"; 38 | DB.exec db {| 39 | CREATE INDEX IF NOT EXISTS plugins_idx on plugins(name); 40 | |} |> check_db_; 41 | 42 | let tr_plugin (n,sub) = 43 | Printf.printf "inserting %s\n%!" n; 44 | if n="factoids" then ( 45 | 46 | DB.exec db {| 47 | CREATE TABLE IF NOT EXISTS 48 | factoids ( 49 | key TEXT NOT NULL, 50 | value TEXT NOT NULL, 51 | UNIQUE (key) on CONFLICT FAIL 52 | ) STRICT; 53 | |} |> check_db_; 54 | 55 | DB.exec db {| 56 | CREATE INDEX IF NOT EXISTS factoids_idx on factoids(key); 57 | |} |> check_db_; 58 | 59 | let l = J.Util.to_assoc sub in 60 | let stmt = DB.prepare db {| INSERT INTO factoids(key,value) VALUES (?,?); |} in 61 | List.iter 62 | (fun (key, value) -> 63 | let str_val = J.to_string value in 64 | 65 | DB.reset stmt |> check_db_; 66 | DB.bind_text stmt 1 key |> check_db_; 67 | DB.bind_text stmt 2 str_val |> check_db_; 68 | DB.step stmt |> check_db_; 69 | ) l; 70 | 71 | DB.finalize stmt |> check_db_; 72 | 73 | 74 | ) else if n="social" then ( 75 | DB.exec db 76 | {| CREATE TABLE IF NOT EXISTS 77 | social(name TEXT NOT NULL, 78 | value TEXT NOT NULL, 79 | UNIQUE (name) ON CONFLICT FAIL 80 | ) STRICT; 81 | |} |> check_db_; 82 | DB.exec db 83 | {| CREATE INDEX IF NOT EXISTS idx_social on social(name); |} 84 | |> check_db_; 85 | 86 | let l = J.Util.to_assoc sub in 87 | (* add value, but be ready to merge if a nick was present several 88 | times (possibly because of casing inconsistencies) *) 89 | let stmt = DB.prepare db 90 | {| INSERT INTO social(name,value) VALUES (?1,?2) 91 | ON CONFLICT(name) DO 92 | UPDATE SET value = 93 | json_object( 94 | 'ignore_user', 95 | ( CASE json_extract(?2, '$.ignore_user') 96 | OR json_extract(value, '$.ignore_user') 97 | WHEN 1 THEN json('true') 98 | WHEN 0 THEN json('false') END), 99 | 'lastSeen', 100 | max(json_extract(?2, '$.lastSeen'), json_extract(value, '$.lastSeen')), 101 | 'to_tell', 102 | (SELECT json_group_array(x.value) FROM 103 | ( SELECT value FROM json_each(value, '$.tell') UNION 104 | SELECT value FROM json_each(?2, '$.tell' )) 105 | as x) 106 | ); 107 | |} in 108 | List.iter 109 | (fun (name, value) -> 110 | let str_val = J.to_string value in 111 | let name = String.lowercase_ascii name in 112 | 113 | DB.reset stmt |> check_db_; 114 | DB.bind_text stmt 1 name |> check_db_; 115 | DB.bind_text stmt 2 str_val |> check_db_; 116 | DB.step stmt |> check_db_; 117 | ) l; 118 | 119 | DB.finalize stmt |> check_db_; 120 | 121 | 122 | ) else ( 123 | let sub = J.to_string sub in 124 | let stmt = DB.prepare db "INSERT INTO plugins(name,value) VALUES (?,?);" in 125 | DB.bind_text stmt 1 n |> check_db_; 126 | DB.bind_text stmt 2 sub |> check_db_; 127 | DB.step stmt |> check_db_; 128 | DB.finalize stmt |> check_db_; 129 | ) 130 | in 131 | 132 | let j = Yojson.Safe.from_file !file in 133 | begin match j with 134 | | `Assoc l -> 135 | DB.exec db "BEGIN;" |> check_db_; 136 | 137 | List.iter tr_plugin l; 138 | 139 | Printf.printf "commit\n%!"; 140 | DB.exec db "COMMIT;" |> check_db_; 141 | 142 | | _ -> failwith "expected json to be an object" 143 | end; 144 | 145 | () 146 | -------------------------------------------------------------------------------- /src/web/Giphy.atd: -------------------------------------------------------------------------------- 1 | 2 | type json = abstract 3 | 4 | type image = { 5 | i_url : string; 6 | } 7 | 8 | type images = { 9 | ?images_original : image option; 10 | ?images_downsized : image option; 11 | } 12 | 13 | type search_entry = { 14 | type_ : string; 15 | url: string; 16 | embed_url: string; 17 | images: images; 18 | } 19 | 20 | type search_result = { 21 | ~data : search_entry list; 22 | ~meta : json; 23 | ~pagination : json; 24 | } 25 | -------------------------------------------------------------------------------- /src/web/Movie.atd: -------------------------------------------------------------------------------- 1 | type maybe = string wrap 2 | type year = string wrap 3 | 4 | type search_entry = { 5 | ~s_title : maybe; 6 | s_id : string; 7 | } 8 | 9 | type query_entry = { 10 | ~title : maybe; 11 | id : string; 12 | ~year : year; 13 | ~rating : float; 14 | ~plot : maybe; 15 | } 16 | 17 | type search_result = { 18 | ~count : int; 19 | ~results : search_entry list; 20 | } 21 | -------------------------------------------------------------------------------- /src/web/Plugin_movie.ml: -------------------------------------------------------------------------------- 1 | open Calculon 2 | open CCFun 3 | open Lwt_infix 4 | 5 | let get_body uri = 6 | let run () = 7 | Curly.run ~args:[ "-L" ] 8 | Curly.(Request.make ~url:(Uri.to_string uri) ~meth:`GET ()) 9 | |> function 10 | | Ok { Curly.Response.body; _ } -> body 11 | | Error e -> raise (Failure (Format.asprintf "%a" Curly.Error.pp e)) 12 | in 13 | Lwt_preemptive.detach run () 14 | 15 | type query = Movie of string | Serie of string 16 | 17 | let query_movie s = Movie s 18 | let query_serie s = Serie s 19 | let api_prefix = Uri.of_string "http://omdbapi.com/" 20 | 21 | let make_search_uri query = 22 | let title, kind = 23 | match query with 24 | | Movie title -> title, "movie" 25 | | Serie title -> title, "series" 26 | in 27 | Uri.add_query_params' api_prefix 28 | [ "v", "1"; "r", "json"; "s", title; "type", kind ] 29 | 30 | let make_get_uri id = 31 | Uri.add_query_params' api_prefix [ "v", "1"; "r", "json"; "i", id ] 32 | 33 | let parse_search body = 34 | try Movie_j.search_result_of_string body 35 | with exn -> 36 | Printf.printf "invalid imdb search response (%s) : %S" 37 | (Printexc.to_string exn) body; 38 | { Movie_t.results = []; count = 0 } 39 | 40 | let parse_get body = 41 | try Option.some @@ Movie_j.query_entry_of_string body 42 | with exn -> 43 | Printf.printf "invalid imdb query response (%s) : %S" 44 | (Printexc.to_string exn) body; 45 | None 46 | 47 | let search query = make_search_uri query |> get_body >|= parse_search 48 | let get_infos id = make_get_uri id |> get_body >|= parse_get 49 | 50 | let ellipsis n s = 51 | if String.length s > n then ( 52 | try 53 | let last = String.rindex_from s n ' ' in 54 | let s = Bytes.sub (Bytes.of_string s) 0 (last + 4) in 55 | Bytes.blit_string "... " 0 s last 4; 56 | Bytes.to_string s 57 | with Not_found -> CCString.take n s 58 | ) else 59 | s 60 | 61 | let make_imdb_url id = String.concat "/" [ "http://www.imdb.com/title"; id ] 62 | 63 | let show_result ?buffer (title, r) = 64 | let open Printf in 65 | let open Movie_t in 66 | let buffer = buffer |> Option.get_or_lazy (fun () -> Buffer.create 10) in 67 | Buffer.clear buffer; 68 | bprintf buffer "%S " (ellipsis 50 title); 69 | Option.iter (bprintf buffer "(%d) ") r.year; 70 | bprintf buffer "- %.1f " r.rating; 71 | Option.iter (Buffer.add_string buffer % ellipsis 150) r.plot; 72 | Buffer.add_string buffer @@ make_imdb_url r.id; 73 | Buffer.contents buffer 74 | 75 | let title { Movie_t.s_title; _ } = s_title 76 | let get_id { Movie_t.s_id; _ } = s_id 77 | 78 | let refine_results ?(n = 3) results = 79 | results.Movie_t.results 80 | |> CCList.filter (Option.is_some % title) 81 | |> CCList.take n |> List.map get_id 82 | |> Lwt_list.filter_map_p get_infos 83 | 84 | let format_seq ?n results = 85 | let buffer = Buffer.create 100 in 86 | let title { Movie_t.title; _ } = title in 87 | let* results = refine_results ?n results in 88 | let* l = 89 | Lwt_list.filter_map_p 90 | (fun r -> Lwt.return @@ Option.map (flip CCPair.make r) @@ title r) 91 | results 92 | in 93 | Lwt_list.map_p (fun x -> Lwt.return @@ show_result ~buffer x) l 94 | 95 | let mk_movie_cmd cmd q_of_str = 96 | Command.make_simple_l ~descr:"look for movies/series" ~prio:10 ~cmd 97 | (fun _ s -> String.trim s |> q_of_str |> search >>= format_seq) 98 | 99 | let cmd_film = mk_movie_cmd "film" query_movie 100 | let cmd_serie = mk_movie_cmd "serie" query_serie 101 | let plugin = [ cmd_film; cmd_serie ] |> Plugin.of_cmds 102 | -------------------------------------------------------------------------------- /src/web/Plugin_web.ml: -------------------------------------------------------------------------------- 1 | (** {1 Commands querying the Web} *) 2 | 3 | open Calculon 4 | open Soup 5 | open Lwt_infix 6 | module Log = Core.Log 7 | 8 | let get_body uri : _ Lwt.t = 9 | let run () = 10 | Curly.run ~args:[ "-L" ] 11 | Curly.(Request.make ~url:(Uri.to_string uri) ~meth:`GET ()) 12 | |> function 13 | | Ok { Curly.Response.body; _ } -> body 14 | | Error e -> raise (Failure (Format.asprintf "%a" Curly.Error.pp e)) 15 | in 16 | Lwt_preemptive.detach run () 17 | 18 | let page_title ~with_description uri : _ Lwt.t = 19 | let* body = get_body uri in 20 | let tags = Og.Parser.parse_string body in 21 | let title_descr = 22 | List.fold_left 23 | (fun (t, d) -> function 24 | | Og.Title title when t = None && title <> "" -> Some title, d 25 | | Og.Description descr when d = None && descr <> "" && with_description 26 | -> 27 | t, Some descr 28 | | _ -> t, d) 29 | (None, None) tags 30 | in 31 | match title_descr with 32 | | Some title, Some description -> 33 | let msg = Format.asprintf "%s : %s" title description in 34 | (* Log.logf "og:: %s" msg; *) 35 | Lwt.return @@ Some msg 36 | | Some title, None -> 37 | let msg = Format.asprintf "%s" title in 38 | (* Log.logf "og:title %s" msg; *) 39 | Lwt.return @@ Some msg 40 | | _, _ -> Lwt.return (parse body $ "title" |> leaf_text) 41 | 42 | let youtube_hosts = 43 | [ "youtube.com"; "www.youtube.com"; "youtu.be"; "www.youtu.be" ] 44 | 45 | let cmd_yt = 46 | Command.make_simple ~prio:10 ~cmd:"yt" 47 | ~descr:"lookup description of given youtube URL" (fun _ s -> 48 | let uri = Uri.of_string (String.trim s) in 49 | match Uri.host uri with 50 | | Some host when List.mem host youtube_hosts -> 51 | page_title ~with_description:true uri 52 | | _ -> Lwt.return None) 53 | 54 | let find_yt_ids ?(n = 1) (body : string) : string list = 55 | let ast = parse body in 56 | Soup.select "#results li li > div" ast 57 | |> Soup.to_list |> CCList.take n 58 | |> CCList.filter_map (Soup.attribute "data-context-item-id") 59 | |> List.map (fun id -> "https://youtube.com/watch?v=" ^ id) 60 | 61 | let get_youtube_search (query : string) : string Lwt.t = 62 | let uri = Uri.of_string "https://www.youtube.com/results" in 63 | let uri = Uri.add_query_params' uri [ "sp", "EgIQAQ%3D%3D"; "q", query ] in 64 | Lwt.catch 65 | (fun () -> get_body uri) 66 | (function 67 | | Failure e -> 68 | Log.err (fun k -> k "error in fetching `%s`:\n%s" query e); 69 | Lwt.return "" 70 | | e -> 71 | Log.err (fun k -> 72 | k "error in fetching `%s`:\n%s" query @@ Printexc.to_string e); 73 | Lwt.return "") 74 | 75 | let cmd_yt_search = 76 | Command.make_simple_l ~prio:10 ~cmd:"yt_search" ~descr:"lookup on youtube" 77 | (fun _ s -> 78 | Log.debug (fun k -> k "yt_search `%s`" s); 79 | let* urls = 80 | let+ body = get_youtube_search (String.trim s) in 81 | Log.debug (fun k -> k "yt_search: body of size %d" (String.length body)); 82 | find_yt_ids ~n:1 body 83 | in 84 | Lwt_list.fold_left_s 85 | (fun acc url -> 86 | Log.debug (fun k -> k "Getting metadata for url: `%s`" url); 87 | let+ t = page_title ~with_description:false (Uri.of_string url) in 88 | match t with 89 | | Some x -> 90 | let descr = Format.asprintf "%s : %s" url x in 91 | descr :: acc 92 | | None -> url :: acc) 93 | [] urls) 94 | 95 | (* see https://github.com/Giphy/GiphyAPI *) 96 | module Giphy = struct 97 | let api_key = "dc6zaTOxFJmzC" 98 | let limit = 5 99 | 100 | let mk_query s : Uri.t = 101 | Uri.add_query_params 102 | (Uri.of_string "http://api.giphy.com/v1/gifs/search") 103 | [ "q", [ s ]; "api_key", [ api_key ]; "limit", [ string_of_int limit ] ] 104 | 105 | let search s : string option Lwt.t = 106 | let uri = mk_query s in 107 | Lwt.catch 108 | (fun () -> 109 | let* s = get_body uri in 110 | Log.debug (fun k -> k "query to giphy returned:@.%s" s); 111 | let r = Giphy_j.search_result_of_string s in 112 | match r.Giphy_j.data with 113 | | [] -> 114 | Log.debug (fun k -> k "giphy: no data"); 115 | Lwt.return None 116 | | l -> 117 | let r = Prelude.random_l l in 118 | Log.info (fun k -> 119 | k "giphy: pick `%s` in list of len %d" r.Giphy_j.url 120 | (List.length l)); 121 | let images = r.Giphy_j.images in 122 | (match 123 | images.Giphy_j.images_original, images.Giphy_j.images_downsized 124 | with 125 | | Some i, _ -> Lwt.return @@ Some i.Giphy_j.i_url 126 | | None, Some i -> Lwt.return @@ Some i.Giphy_j.i_url 127 | | None, None -> 128 | (* default: return the embed_url *) 129 | Log.err (fun k -> 130 | k 131 | "giphy: could not get `original` or `downsized` picture for \ 132 | `%s`" 133 | r.Giphy_j.url); 134 | Lwt.return @@ Some r.Giphy_j.embed_url)) 135 | (fun _ -> Lwt.return None) 136 | 137 | let cmd = 138 | Command.make_simple ~prio:10 ~cmd:"giphy" 139 | ~descr:"lookup on giphy (Powered by Giphy)" (fun _ s -> 140 | let s = String.trim s in 141 | if s = "" then 142 | Lwt.return None 143 | else 144 | search (String.trim s) >|= function 145 | | Some x -> Some x 146 | | None -> Some "not found") 147 | end 148 | 149 | let find_emoji (s : string) : string option Lwt.t = 150 | let find_h1 ast = 151 | let open Option.Infix in 152 | let open Soup in 153 | let* h1 = ast $? "article h1" in 154 | let+ em = h1 $? ".emoji" >>= Soup.leaf_text 155 | and+ descr = h1 |> children |> last >>= leaf_text in 156 | em, descr 157 | and find_search ast = 158 | let open Option.Infix in 159 | let* a = ast $? ".search-results > li a" in 160 | let+ href = Soup.attribute "href" a in 161 | "https://emojipedia.org/" ^ href 162 | in 163 | 164 | let query = Printf.sprintf "https://emojipedia.org/search/?q=%s" s in 165 | Log.debug (fun k -> k "emoji: query is '%s'" query); 166 | Lwt.catch 167 | (fun () -> 168 | let* body = get_body (Uri.of_string query) in 169 | let ast = Soup.parse body in 170 | Lwt.return 171 | @@ 172 | match find_h1 ast, find_search ast with 173 | | Some (em, title), _ -> 174 | Some (Printf.sprintf "%s: %s (%s)" em title query) 175 | | None, Some href -> Some href 176 | | None, None -> Some (Printf.sprintf "not found")) 177 | (fun e -> 178 | Log.err (fun k -> k "emoji: query failed:@.%s" (Printexc.to_string e)); 179 | Lwt.return None) 180 | 181 | let cmd_emoji = 182 | Command.make_simple ~descr:"look for emojis" ~cmd:"emoji" ~prio:10 183 | (fun _msg s -> 184 | let s = String.trim s in 185 | find_emoji s) 186 | 187 | let plugin = [ cmd_yt; cmd_yt_search; Giphy.cmd; cmd_emoji ] |> Plugin.of_cmds 188 | -------------------------------------------------------------------------------- /src/web/dune: -------------------------------------------------------------------------------- 1 | 2 | (library 3 | (name calculon_web) 4 | (public_name calculon-web) 5 | (flags :standard -open Calculon_common) 6 | (libraries calculon atdgen curly lambdasoup uri)) 7 | 8 | (rule 9 | (targets Movie_j.ml Movie_j.mli) 10 | (deps Movie.atd) 11 | (action (run atdgen -j -j-std %{deps}))) 12 | 13 | (rule 14 | (targets Movie_t.ml Movie_t.mli) 15 | (deps Movie.atd) 16 | (action (run atdgen -t -j-std %{deps}))) 17 | 18 | (rule 19 | (targets Giphy_j.ml Giphy_j.mli) 20 | (deps Giphy.atd) 21 | (action (run atdgen -j -j-std %{deps}))) 22 | 23 | (rule 24 | (targets Giphy_t.ml Giphy_t.mli) 25 | (deps Giphy.atd) 26 | (action (run atdgen -t -j-std %{deps}))) 27 | -------------------------------------------------------------------------------- /src/web/movie_schema.ml: -------------------------------------------------------------------------------- 1 | module Maybe = struct 2 | type t = string option 3 | 4 | let wrap = function 5 | | "N/A" -> None 6 | | s -> Some s 7 | 8 | let unwrap = Option.value ~default:"N/A" 9 | end 10 | 11 | module Year = struct 12 | type t = int option 13 | 14 | let wrap s = 15 | match Stringext.split ~max:3 ~on:' ' (String.trim s) with 16 | | [ _; _; year ] -> (try Some (int_of_string year) with _ -> None) 17 | | _ -> None 18 | 19 | let unwrap = Option.fold ~none:"N/A" ~some:(Printf.sprintf "1 Jan %d") 20 | end 21 | -------------------------------------------------------------------------------- /src/web/og.ml: -------------------------------------------------------------------------------- 1 | (** These data-structures are for holding meta-data 2 | expressed by the {{:http://ogp.me/}graph protocol}. 3 | *) 4 | 5 | type url = { name : string } 6 | 7 | type locale = { language : string; territory : string } 8 | 9 | type og_type = TMusic | TVideo | TWebsite | 10 | TArticle | TBook | TProfile | TOther of string 11 | 12 | type og_determiner = A | An | The | NoDet | Auto 13 | 14 | type og_video_metadata = 15 | | VTag of string 16 | | VDuration of int 17 | 18 | type og_metadata = 19 | | Title of string | Type of og_type | Image of url | Url of url 20 | | Audio of url | Description of string | Determiner of og_determiner 21 | | Locale of locale | AlternateLocale of locale | SiteName of string 22 | | Video of url | VideoMeta of og_video_metadata | UnparsedMeta of string 23 | 24 | type basic_metadata = { og_title : string; 25 | og_type : og_type; 26 | og_image : url; 27 | og_url : url; 28 | } 29 | 30 | let parse_type = function 31 | | "video" -> TVideo 32 | | "music" -> TMusic 33 | (* TODO: add more types / subtypes *) 34 | | str -> TOther str 35 | 36 | let parse_url str = Some { name = str } 37 | 38 | let parse_locale str = 39 | match Re.split (Re.str "_" |> Re.compile) str with 40 | | language :: territory :: _ -> Some { language; territory } 41 | | _ -> None 42 | 43 | let make_title str = Title str 44 | let make_type t = Type t 45 | let make_image url = Image url 46 | let make_audio url = Audio url 47 | let make_description str = Description str 48 | let make_determiner det = Determiner det 49 | let make_locale l = Locale l 50 | let make_alternate_locale l = AlternateLocale l 51 | let make_site_name str = SiteName str 52 | let make_video url = Video url 53 | let make_video_metadata meta = VideoMeta meta 54 | let make_url url = Url url 55 | 56 | let make_video_tag tag = VTag tag 57 | let make_video_duration dur = VDuration dur 58 | 59 | let format_url formatter { name } = 60 | Format.fprintf formatter "%s" name 61 | 62 | let format_locale formatter { language; territory } = 63 | Format.fprintf formatter "%s_%s" language territory 64 | 65 | let format_determiner formatter = function 66 | | A -> Format.fprintf formatter "a" 67 | | An -> Format.fprintf formatter "an" 68 | | The -> Format.fprintf formatter "the" 69 | | NoDet -> Format.fprintf formatter "" 70 | | Auto -> Format.fprintf formatter "" 71 | 72 | let format_type formatter t = 73 | let str = match t with 74 | | TMusic -> "music" 75 | | TVideo -> "video" 76 | | TWebsite -> "website" 77 | | TArticle -> "article" 78 | | TBook -> "book" 79 | | TProfile -> "profile" 80 | | TOther str -> "other:"^str 81 | in Format.fprintf formatter "%s" str 82 | 83 | 84 | let format_video_metadata formatter = function 85 | | VTag tag -> Format.fprintf formatter "tag: %s" tag 86 | | VDuration dur -> Format.fprintf formatter "duration: %d s" dur 87 | 88 | let format_metadata formatter = function 89 | | Title t -> 90 | Format.fprintf formatter "Title: %s" t 91 | | Type t -> 92 | Format.fprintf formatter "Type: %a" format_type t 93 | | Image url -> 94 | Format.fprintf formatter "Image: %a" format_url url 95 | | Url url -> 96 | Format.fprintf formatter "Url: %a" format_url url 97 | | Audio url -> 98 | Format.fprintf formatter "Audio: %a" format_url url 99 | | Description str -> 100 | Format.fprintf formatter "Description: %s" str 101 | | Determiner og_determiner -> 102 | Format.fprintf formatter "Determiner %a" format_determiner og_determiner 103 | | Locale locale -> 104 | Format.fprintf formatter "Locale: %a" format_locale locale 105 | | AlternateLocale locale -> 106 | Format.fprintf formatter "Alternate Locale: %a" format_locale locale 107 | | SiteName str -> 108 | Format.fprintf formatter "Site Name: %s" str 109 | | Video url -> 110 | Format.fprintf formatter "Video: %a" format_url url 111 | | VideoMeta meta -> 112 | Format.fprintf formatter "Video %a" format_video_metadata meta 113 | | UnparsedMeta name -> 114 | Format.fprintf formatter "Unparsed tag: %s" name 115 | 116 | module Parser = struct 117 | open Soup 118 | let og_prefix = Re.Perl.compile_pat "^og:" 119 | 120 | let og_parser list elem = 121 | let prop constructor x list = 122 | match attribute "content" x with 123 | | None -> list 124 | | Some str -> constructor str :: list 125 | in 126 | let optprop constructor x list = 127 | match attribute "content" x with 128 | | None -> list 129 | | Some str -> match constructor str with 130 | | Some elem -> elem :: list 131 | | None -> list 132 | in 133 | let optparser parser constructor str = 134 | match parser str with 135 | | None -> None 136 | | Some url -> Some (constructor url) 137 | in 138 | let purl = optparser parse_url in 139 | let plocale = optparser parse_locale in 140 | match attribute "property" elem with 141 | | Some "og:title" -> prop make_title elem list 142 | | Some "og:type" -> prop (fun x -> make_type (parse_type x)) elem list 143 | | Some "og:image" -> optprop (purl make_image) elem list 144 | | Some "og:url" -> optprop (purl make_url) elem list 145 | | Some "og:audio" -> optprop (purl make_audio) elem list 146 | | Some "og:description" -> prop make_description elem list 147 | | Some "og:determiner" -> (Determiner Auto) :: list 148 | | Some "og:locale" -> optprop (plocale make_locale) elem list 149 | | Some "og:locale:alternate" -> optprop (plocale make_locale) elem list 150 | | Some "og:site_name" -> prop make_site_name elem list 151 | | Some "og:video" -> optprop (purl make_video) elem list 152 | | Some "og:video:tag" -> 153 | prop (fun x -> x |> make_video_tag |> make_video_metadata ) elem list 154 | | Some str when Re.execp og_prefix str -> 155 | UnparsedMeta str :: list 156 | | Some _ -> list 157 | | None -> list 158 | 159 | let parse_string content = 160 | let soup = parse content in 161 | let meta_tags = soup $$ "meta" in 162 | let og_nodes = fold og_parser [] meta_tags in 163 | List.rev og_nodes 164 | end 165 | -------------------------------------------------------------------------------- /src/web/og.mli: -------------------------------------------------------------------------------- 1 | (** These data-structures are for holding meta-data 2 | expressed by the {{:http://ogp.me/}open graph protocol}. 3 | 4 | The basic information represented is the site name, title, content type, 5 | canonical url and a preview image. If the content is music or video data, 6 | additional data, additional data like tags or length may be present. Even 7 | though the protocal requires a minimum information of title, type, image 8 | and url, the webpage might be malformed. Parse.parse_string therefore just 9 | returns a list of og_metadata. 10 | *) 11 | 12 | type url = { name : string } 13 | type locale = { language : string; territory : string } 14 | 15 | type og_type = TMusic | TVideo | TWebsite | 16 | TArticle | TBook | TProfile | TOther of string 17 | type og_determiner = A | An | The | NoDet | Auto 18 | 19 | type og_video_metadata = 20 | | VTag of string 21 | | VDuration of int 22 | 23 | type og_metadata = 24 | | Title of string | Type of og_type | Image of url | Url of url 25 | | Audio of url | Description of string | Determiner of og_determiner 26 | | Locale of locale | AlternateLocale of locale | SiteName of string 27 | | Video of url | VideoMeta of og_video_metadata | UnparsedMeta of string 28 | 29 | type basic_metadata = { og_title : string; 30 | og_type : og_type; 31 | og_image : url; 32 | og_url : url 33 | } 34 | 35 | val parse_url : string -> url option 36 | val parse_locale : string -> locale option 37 | val parse_type : string -> og_type 38 | 39 | val make_title : string -> og_metadata 40 | val make_type : og_type -> og_metadata 41 | val make_image : url -> og_metadata 42 | val make_audio : url -> og_metadata 43 | val make_description : string -> og_metadata 44 | val make_determiner : og_determiner -> og_metadata 45 | val make_locale : locale -> og_metadata 46 | val make_alternate_locale : locale -> og_metadata 47 | val make_site_name : string -> og_metadata 48 | val make_video : url -> og_metadata 49 | val make_video_metadata : og_video_metadata -> og_metadata 50 | val make_url : url -> og_metadata 51 | 52 | val make_video_tag : string -> og_video_metadata 53 | val make_video_duration : int -> og_video_metadata 54 | 55 | val format_metadata : Format.formatter -> og_metadata -> unit 56 | 57 | module Parser : sig 58 | val parse_string : string -> og_metadata list 59 | end 60 | --------------------------------------------------------------------------------