├── .config ├── dotnet-tools.json └── dotnet-tools.json.license ├── .dockerignore ├── .editorconfig ├── .github └── workflows │ ├── docker.yml │ ├── main.yml │ └── release.yml ├── .gitignore ├── .idea └── .idea.Emulsion │ └── .idea │ └── dictionaries │ └── fried.xml ├── .reuse └── dep5 ├── CHANGELOG.md ├── CONTRIBUTING.md ├── Directory.Build.props ├── Dockerfile ├── Emulsion.ContentProxy ├── ContentStorage.fs ├── Emulsion.ContentProxy.fsproj ├── FileCache.fs ├── Proxy.fs └── SimpleHttpClientFactory.fs ├── Emulsion.Database ├── DataStorage.fs ├── DatabaseSettings.fs ├── Emulsion.Database.fsproj ├── EmulsionDbContext.fs ├── Entities.fs ├── Migrations │ ├── 20211026164449_Initial.fs │ ├── 20211031102019_TelegramContentUniqueConstraint.fs │ ├── 20220828133844_ContentFileNameAndMimeType.fs │ ├── 20220828152910_ContentChatId.fs │ ├── 20230625203424_ArchiveEntry.fs │ └── EmulsionDbContextModelSnapshot.fs └── QueryableEx.fs ├── Emulsion.MessageArchive.Frontend ├── Emulsion.MessageArchive.Frontend.proj ├── api.d.ts ├── app.tsx ├── index.html ├── package-lock.json ├── package-lock.json.license ├── package.json ├── package.json.license ├── style.less ├── tsconfig.json └── tsconfig.json.license ├── Emulsion.Messaging ├── AssemblyInfo.fs ├── Emulsion.Messaging.fsproj ├── Message.fs ├── MessageSender.fs └── MessageSystem.fs ├── Emulsion.Settings ├── Emulsion.Settings.fsproj └── Settings.fs ├── Emulsion.Telegram ├── AssemblyInfo.fs ├── Client.fs ├── Emulsion.Telegram.fsproj ├── Funogram.fs ├── Html.fs └── LinkGenerator.fs ├── Emulsion.TestFramework ├── Emulsion.TestFramework.fsproj ├── Exceptions.fs ├── FileCacheUtil.fs ├── Lifetimes.fs ├── LockedBuffer.fs ├── Logging.fs ├── Signals.fs ├── StreamUtils.fs ├── TelegramClientMock.fs ├── TestDataStorage.fs ├── Waiter.fs └── WebFileStorage.fs ├── Emulsion.Tests ├── ContentProxy │ ├── ContentStorageTests.fs │ ├── FileCacheTests.fs │ └── ProxyTests.fs ├── Database │ ├── DataStorageTests.fs │ └── DatabaseStructureTests.fs ├── Emulsion.Tests.fsproj ├── ExceptionUtilsTests.fs ├── LifetimesTests.fs ├── LoggingTests.fs ├── MessageSenderTests.fs ├── MessageSystemTests │ ├── MessageSystemBaseTests.fs │ └── WrapRunTests.fs ├── MessagingCoreTests.fs ├── SettingsTests.fs ├── Telegram │ ├── FunogramTests.fs │ ├── Html.fs │ └── LinkGeneratorTests.fs ├── Web │ └── ContentControllerTests.fs └── Xmpp │ ├── EmulsionXmppTests.fs │ ├── SharpXmppHelperTests.fs │ ├── SharpXmppPingHandlerTests.fs │ ├── XmppClientFactory.fs │ ├── XmppClientRoomTests.fs │ ├── XmppClientTests.fs │ └── XmppMessageFactory.fs ├── Emulsion.Web ├── ContentController.fs ├── Emulsion.Web.fsproj ├── HistoryController.fs └── WebServer.fs ├── Emulsion.sln ├── Emulsion.sln.DotSettings ├── Emulsion.sln.license ├── Emulsion ├── Emulsion.fsproj ├── ExceptionUtils.fs ├── Lifetimes.fs ├── Logging.fs ├── MessageArchive.fs ├── MessagingCore.fs ├── Program.fs └── Xmpp │ ├── EmulsionXmpp.fs │ ├── SharpXmppClient.fs │ ├── SharpXmppHelper.fs │ ├── SharpXmppPingHandler.fs │ ├── Types.fs │ ├── XmppClient.fs │ └── XmppMessageSystem.fs ├── LICENSE.md ├── LICENSES └── MIT.txt ├── MAINTAINERSHIP.md ├── NuGet.Config ├── README.md ├── emulsion.example.json ├── emulsion.example.json.license ├── renovate.json ├── renovate.json.license └── scripts ├── Get-Version.ps1 └── Test-Encoding.ps1 /.config/dotnet-tools.json: -------------------------------------------------------------------------------- 1 | { 2 | "version": 1, 3 | "isRoot": true, 4 | "tools": { 5 | "dotnet-ef": { 6 | "version": "9.0.2", 7 | "commands": [ 8 | "dotnet-ef" 9 | ] 10 | } 11 | } 12 | } -------------------------------------------------------------------------------- /.config/dotnet-tools.json.license: -------------------------------------------------------------------------------- 1 | SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | 3 | SPDX-License-Identifier: MIT 4 | -------------------------------------------------------------------------------- /.dockerignore: -------------------------------------------------------------------------------- 1 | # SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | # 3 | # SPDX-License-Identifier: MIT 4 | 5 | .git 6 | .idea 7 | .vs 8 | 9 | **/bin 10 | **/obj 11 | 12 | *.md 13 | *.yml 14 | 15 | *.json 16 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | # SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | # 3 | # SPDX-License-Identifier: MIT 4 | 5 | root = true 6 | 7 | [*] 8 | charset = utf-8 9 | indent_style = space 10 | indent_size = 4 11 | max_line_length = 120 12 | trim_trailing_whitespace = true 13 | insert_final_newline = true 14 | 15 | [*.fsproj] 16 | indent_size = 2 17 | insert_final_newline = false 18 | 19 | [*.md] 20 | max_line_length = 80 21 | 22 | [*.yml] 23 | indent_size = 2 24 | -------------------------------------------------------------------------------- /.github/workflows/docker.yml: -------------------------------------------------------------------------------- 1 | # SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | # 3 | # SPDX-License-Identifier: MIT 4 | 5 | name: Docker 6 | on: 7 | push: 8 | branches: 9 | - master 10 | tags: 11 | - 'v*' 12 | pull_request: 13 | branches: 14 | - master 15 | schedule: 16 | - cron: '0 0 * * 6' # every Saturday 17 | 18 | jobs: 19 | publish: 20 | runs-on: ubuntu-24.04 21 | steps: 22 | - name: Clone the repository 23 | uses: actions/checkout@v4 24 | 25 | - name: Read version from ref 26 | id: version 27 | shell: pwsh 28 | run: echo "version=$(./scripts/Get-Version.ps1 -RefName $env:GITHUB_REF)" >> $env:GITHUB_OUTPUT 29 | 30 | - name: Login to Docker Hub 31 | if: github.event_name == 'push' && contains(github.ref, 'refs/tags/') 32 | uses: docker/login-action@v3 33 | with: 34 | username: ${{ secrets.DOCKER_USERNAME }} 35 | password: ${{ secrets.DOCKER_PASSWORD }} 36 | 37 | - name: Build and Push Docker Images 38 | uses: docker/build-push-action@v6 39 | with: 40 | tags: codingteam/emulsion:latest,codingteam/emulsion:v${{ steps.version.outputs.version }} 41 | push: ${{ github.event_name == 'push' && contains(github.ref, 'refs/tags/') && 'true' || 'false' }} 42 | -------------------------------------------------------------------------------- /.github/workflows/main.yml: -------------------------------------------------------------------------------- 1 | # SPDX-FileCopyrightText: 2025 Emulsion contributors 2 | # 3 | # SPDX-License-Identifier: MIT 4 | 5 | name: Main 6 | on: 7 | push: 8 | branches: 9 | - master 10 | pull_request: 11 | branches: 12 | - master 13 | schedule: 14 | - cron: '0 0 * * 6' 15 | 16 | jobs: 17 | main: 18 | runs-on: ${{ matrix.environment }} 19 | strategy: 20 | matrix: 21 | environment: 22 | - macos-14 23 | - ubuntu-24.04 24 | - windows-2022 25 | env: 26 | DOTNET_NOLOGO: 1 27 | DOTNET_CLI_TELEMETRY_OPTOUT: 1 28 | NUGET_PACKAGES: ${{ github.workspace }}/.github/nuget-packages 29 | steps: 30 | - uses: actions/checkout@v4 31 | - name: Set up .NET SDK 32 | uses: actions/setup-dotnet@v4 33 | with: 34 | dotnet-version: 9.0.x 35 | - name: NuGet cache 36 | uses: actions/cache@v4 37 | with: 38 | path: ${{ env.NUGET_PACKAGES }} 39 | key: ${{ runner.os }}.nuget.${{ hashFiles('**/*.*proj') }} 40 | - name: Build 41 | run: dotnet build 42 | - name: Test 43 | run: dotnet test 44 | timeout-minutes: 10 45 | encoding: 46 | runs-on: ubuntu-24.04 47 | steps: 48 | - uses: actions/checkout@v4 49 | - name: Verify encoding 50 | shell: pwsh 51 | run: scripts/Test-Encoding.ps1 52 | licenses: 53 | runs-on: ubuntu-24.04 54 | steps: 55 | - name: Check out the sources 56 | uses: actions/checkout@v4 57 | - name: REUSE license check 58 | uses: fsfe/reuse-action@v5 59 | -------------------------------------------------------------------------------- /.github/workflows/release.yml: -------------------------------------------------------------------------------- 1 | # SPDX-FileCopyrightText: 2025 Emulsion contributors 2 | # 3 | # SPDX-License-Identifier: MIT 4 | 5 | name: Release 6 | on: 7 | push: 8 | branches: 9 | - master 10 | tags: 11 | - 'v*' 12 | pull_request: 13 | branches: 14 | - master 15 | schedule: 16 | - cron: '0 0 * * 6' # every Saturday 17 | 18 | jobs: 19 | publish: 20 | runs-on: ubuntu-24.04 21 | env: 22 | NUGET_PACKAGES: ${{ github.workspace }}/.github/nuget-packages 23 | steps: 24 | - name: Read version from Git ref 25 | id: version 26 | shell: pwsh 27 | run: echo "version=$(if ($env:GITHUB_REF.StartsWith('refs/tags/v')) { $env:GITHUB_REF -replace '^refs/tags/v', '' } else { 'next' })" >> $env:GITHUB_OUTPUT 28 | 29 | - name: Checkout 30 | uses: actions/checkout@v4 31 | 32 | - name: Read the changelog 33 | uses: ForNeVeR/ChangelogAutomation.action@v2 34 | with: 35 | input: ./CHANGELOG.md 36 | output: ./changelog-section.md 37 | 38 | - name: Upload the changelog 39 | uses: actions/upload-artifact@v4 40 | with: 41 | name: changelog-section.md 42 | path: ./changelog-section.md 43 | 44 | - name: Set up .NET SDK 45 | uses: actions/setup-dotnet@v4 46 | with: 47 | dotnet-version: 9.0.x 48 | - name: NuGet cache 49 | uses: actions/cache@v4 50 | with: 51 | path: ${{ env.NUGET_PACKAGES }} 52 | key: ${{ runner.os }}.nuget.${{ hashFiles('**/*.*proj') }} 53 | - name: Publish 54 | run: dotnet publish Emulsion --output publish -p:UseAppHost=false 55 | - name: Pack 56 | shell: pwsh 57 | run: Compress-Archive -Path publish -DestinationPath emulsion-${{ steps.version.outputs.version }}.zip 58 | 59 | - name: Upload the pack result 60 | uses: actions/upload-artifact@v4 61 | with: 62 | name: emulsion-${{ steps.version.outputs.version }}.zip 63 | path: emulsion-${{ steps.version.outputs.version }}.zip 64 | 65 | - name: Create a release 66 | if: startsWith(github.ref, 'refs/tags/v') 67 | # noinspection SpellCheckingInspection 68 | uses: softprops/action-gh-release@v2 69 | with: 70 | name: Emulsion v${{ steps.version.outputs.version }} 71 | body_path: ./changelog-section.md 72 | files: | 73 | emulsion-${{ steps.version.outputs.version }}.zip 74 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | # 3 | # SPDX-License-Identifier: MIT 4 | 5 | /.idea/ 6 | /.vscode/ 7 | /logs/ 8 | 9 | bin/ 10 | obj/ 11 | node_modules/ 12 | 13 | emulsion.json 14 | 15 | *.db 16 | *.db-shm 17 | *.db-wal 18 | *.user 19 | 20 | .fake 21 | .ionide 22 | -------------------------------------------------------------------------------- /.idea/.idea.Emulsion/.idea/dictionaries/fried.xml: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | andivionian 5 | aquana 6 | codingteam 7 | efcore 8 | fhtagn 9 | maintainership 10 | 11 | 12 | -------------------------------------------------------------------------------- /.reuse/dep5: -------------------------------------------------------------------------------- 1 | Format: https://www.debian.org/doc/packaging-manuals/copyright-format/1.0/ 2 | Upstream-Name: Emulsion 3 | Upstream-Contact: Friedrich von Never 4 | Source: https://github.com/codingteam/emulsion 5 | 6 | Files: .idea/**/* 7 | Copyright: 2024 Emulsion contributors 8 | License: MIT 9 | 10 | Files: *.DotSettings 11 | Copyright: 2024 Emulsion contributors 12 | License: MIT 13 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | 6 | 7 | Contributor Guide 8 | ================= 9 | 10 | Prerequisites 11 | ------------- 12 | To develop Emulsion, make sure you've installed the following tools: 13 | - [.NET SDK][dotnet] 9.0 or later, 14 | - [Node.js][node.js] 18: 15 | - if you use [nvm][] or [nvm-windows][], then run `nvm use 18`. 16 | 17 | Build 18 | ----- 19 | Build the project using the following shell command: 20 | 21 | ```console 22 | $ dotnet build 23 | ``` 24 | 25 | Run 26 | --- 27 | Run the application from sources using the following shell command: 28 | 29 | ```console 30 | $ dotnet run --project ./Emulsion [optional-path-to-json-config-file] 31 | ``` 32 | 33 | Test 34 | ---- 35 | Execute the tests using the following shell command: 36 | 37 | ```console 38 | $ dotnet test 39 | ``` 40 | 41 | License Automation 42 | ------------------ 43 | 44 | If the CI asks you to update the file licenses, follow one of these: 45 | 1. Update the headers manually (look at the existing files), something like this: 46 | ```fsharp 47 | // SPDX-FileCopyrightText: %year% %your name% <%your contact info, e.g. email%> 48 | // 49 | // SPDX-License-Identifier: MIT 50 | ``` 51 | (accommodate to the file's comment style if required). 52 | 2. Alternately, use [REUSE][reuse] tool: 53 | ```console 54 | $ reuse annotate --license MIT --copyright '%your name% <%your contact info, e.g. email%>' %file names to annotate% 55 | ``` 56 | 57 | (Feel free to attribute the changes to "Emulsion contributors " instead of your name in a multi-author file, or if you don't want your name to be mentioned in the project's source: this doesn't mean you'll lose the copyright.) 58 | 59 | 60 | Docker Publish 61 | -------------- 62 | To build and push the container to Docker Hub, use the following shell commands: 63 | 64 | ```console 65 | $ docker build -t codingteam/emulsion:$EMULSION_VERSION \ 66 | -t codingteam/emulsion:latest . 67 | 68 | $ docker login # if necessary 69 | $ docker push codingteam/emulsion:$EMULSION_VERSION 70 | $ docker push codingteam/emulsion:latest 71 | ``` 72 | 73 | where `$EMULSION_VERSION` is the version of the image to publish. 74 | 75 | Updating the Database Structure 76 | ------------------------------- 77 | If you want to update a database structure, you'll need to create a migration. 78 | 79 | This article explains how to create a database migration using [EFCore.FSharp][efcore.fsharp]. 80 | 81 | 1. Change the entity type (see `Emulsion.Database/Entities.fs`), update the `EmulsionDbContext` if required. 82 | 2. Run the following shell commands: 83 | 84 | ```console 85 | $ dotnet tool restore 86 | $ cd Emulsion.Database 87 | $ dotnet ef migrations add 88 | ``` 89 | 90 | [dotnet]: https://dot.net/ 91 | [efcore.fsharp]: https://github.com/efcore/EFCore.FSharp 92 | [node.js]: https://nodejs.org/ 93 | [nvm]: https://github.com/nvm-sh/nvm 94 | [nvm-windows] 95 | -------------------------------------------------------------------------------- /Directory.Build.props: -------------------------------------------------------------------------------- 1 | 6 | 7 | 8 | 9 | true 10 | 11 | 12 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | # SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | # 3 | # SPDX-License-Identifier: MIT 4 | 5 | FROM mcr.microsoft.com/dotnet/sdk:9.0 AS build-env 6 | 7 | # Install Node.js 18 8 | RUN curl -fsSL https://deb.nodesource.com/setup_18.x | bash - \ 9 | && apt-get install -y nodejs \ 10 | && rm -rf /var/lib/apt/lists/* 11 | 12 | WORKDIR /app 13 | 14 | COPY ./Directory.Build.props ./ 15 | COPY ./Emulsion/Emulsion.fsproj ./Emulsion/ 16 | COPY ./Emulsion.ContentProxy/Emulsion.ContentProxy.fsproj ./Emulsion.ContentProxy/ 17 | COPY ./Emulsion.Database/Emulsion.Database.fsproj ./Emulsion.Database/ 18 | COPY ./Emulsion.Messaging/Emulsion.Messaging.fsproj ./Emulsion.Messaging/ 19 | COPY ./Emulsion.MessageArchive.Frontend/Emulsion.MessageArchive.Frontend.proj ./Emulsion.MessageArchive.Frontend/ 20 | COPY ./Emulsion.Settings/Emulsion.Settings.fsproj ./Emulsion.Settings/ 21 | COPY ./Emulsion.Telegram/Emulsion.Telegram.fsproj ./Emulsion.Telegram/ 22 | COPY ./Emulsion.Web/Emulsion.Web.fsproj ./Emulsion.Web/ 23 | 24 | RUN dotnet restore Emulsion 25 | 26 | COPY . ./ 27 | RUN dotnet build Emulsion.MessageArchive.Frontend # required to publish the frontend resources 28 | RUN dotnet publish Emulsion -c Release -o /app/out 29 | 30 | FROM mcr.microsoft.com/dotnet/aspnet:9.0 31 | WORKDIR /app 32 | COPY --from=build-env /app/out . 33 | ENTRYPOINT ["dotnet", "Emulsion.dll"] 34 | -------------------------------------------------------------------------------- /Emulsion.ContentProxy/ContentStorage.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.ContentProxy.ContentStorage 6 | 7 | open Emulsion.Database 8 | open Emulsion.Database.DataStorage 9 | open Emulsion.Database.Entities 10 | open Emulsion.Database.QueryableEx 11 | 12 | type MessageContentIdentity = { 13 | ChatId: int64 14 | ChatUserName: string 15 | MessageId: int64 16 | FileId: string 17 | FileName: string 18 | MimeType: string 19 | } 20 | 21 | let getOrCreateMessageRecord (context: EmulsionDbContext) (id: MessageContentIdentity): Async = async { 22 | let! existingItem = 23 | query { 24 | for content in context.TelegramContents do 25 | where (content.ChatId = id.ChatId 26 | && content.ChatUserName = id.ChatUserName 27 | && content.MessageId = id.MessageId 28 | && content.FileId = id.FileId 29 | && content.FileName = id.FileName 30 | && content.MimeType = id.MimeType) 31 | } |> tryExactlyOneAsync 32 | match existingItem with 33 | | None -> 34 | let newItem = { 35 | Id = 0L 36 | ChatId = id.ChatId 37 | ChatUserName = id.ChatUserName 38 | MessageId = id.MessageId 39 | FileId = id.FileId 40 | FileName = id.FileName 41 | MimeType = id.MimeType 42 | } 43 | do! addAsync context.TelegramContents newItem 44 | return newItem 45 | | Some item -> return item 46 | } 47 | 48 | let getById (context: EmulsionDbContext) (id: int64): Async = async { 49 | return! query { 50 | for content in context.TelegramContents do 51 | where (content.Id = id) 52 | } |> tryExactlyOneAsync 53 | } 54 | -------------------------------------------------------------------------------- /Emulsion.ContentProxy/Emulsion.ContentProxy.fsproj: -------------------------------------------------------------------------------- 1 | 6 | 7 | 8 | 9 | 10 | net9.0 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | -------------------------------------------------------------------------------- /Emulsion.ContentProxy/Proxy.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.ContentProxy.Proxy 6 | 7 | open System 8 | open HashidsNet 9 | 10 | let encodeHashId (salt: string) (id: int64): string = 11 | let hashids = Hashids salt 12 | 13 | // Since hashids.net doesn't support negative numbers, we'll have to split our integer into three groups: 2 bits, 31 14 | // bits and 31 bits. 15 | let low = int id &&& 0x7FFFFFFF 16 | let middle = int(id >>> 31) &&& 0x7FFFFFFF 17 | let high = int(id >>> 62) 18 | 19 | let hashId = hashids.Encode(high, middle, low) 20 | if hashId = "" then failwith $"Cannot generate hashId for id {id}" 21 | hashId 22 | 23 | let decodeHashId (salt: string) (hashId: string): int64 = 24 | let hashids = Hashids salt 25 | let numbers = hashids.Decode hashId |> Array.map int64 26 | match numbers with 27 | | [| high; middle; low |] -> (high <<< 62) ||| (middle <<< 31) ||| low 28 | | _ -> failwith($"Invalid numbers decoded from hashId {hashId}: [" + (String.concat ", " (Seq.map string numbers)) + "]") 29 | 30 | let getLink (baseUri: Uri) (hashId: string): Uri = 31 | Uri(baseUri, $"content/{hashId}") 32 | -------------------------------------------------------------------------------- /Emulsion.ContentProxy/SimpleHttpClientFactory.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.ContentProxy 6 | 7 | open System.Net.Http 8 | 9 | type SimpleHttpClientFactory() = 10 | interface IHttpClientFactory with 11 | member this.CreateClient _ = new HttpClient() 12 | -------------------------------------------------------------------------------- /Emulsion.Database/DataStorage.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Database.DataStorage 6 | 7 | open System.Data 8 | 9 | open Microsoft.EntityFrameworkCore 10 | 11 | let initializeDatabase(context: EmulsionDbContext): Async = async { 12 | let! ct = Async.CancellationToken 13 | do! Async.AwaitTask(context.Database.MigrateAsync(ct)) 14 | } 15 | 16 | let transaction<'a> (settings: DatabaseSettings) (action: EmulsionDbContext -> Async<'a>): Async<'a> = async { 17 | use context = new EmulsionDbContext(settings.ContextOptions) 18 | let! ct = Async.CancellationToken 19 | use! tran = Async.AwaitTask(context.Database.BeginTransactionAsync(IsolationLevel.ReadCommitted, ct)) 20 | let! result = action context 21 | do! Async.AwaitTask(tran.CommitAsync(ct)) 22 | let! _ = Async.AwaitTask(context.SaveChangesAsync(ct)) 23 | return result 24 | } 25 | 26 | let addAsync<'a when 'a : not struct> (dbSet: DbSet<'a>) (entity: 'a): Async = async { 27 | let! ct = Async.CancellationToken 28 | let! _ = Async.AwaitTask(dbSet.AddAsync(entity, ct).AsTask()) 29 | return () 30 | } 31 | -------------------------------------------------------------------------------- /Emulsion.Database/DatabaseSettings.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Database 6 | 7 | open Microsoft.EntityFrameworkCore 8 | 9 | type DatabaseSettings = 10 | { DataSource: string } 11 | 12 | member this.ContextOptions: DbContextOptions = 13 | DbContextOptionsBuilder() 14 | .UseSqlite($"Data Source={this.DataSource}") 15 | .Options 16 | -------------------------------------------------------------------------------- /Emulsion.Database/Emulsion.Database.fsproj: -------------------------------------------------------------------------------- 1 | 6 | 7 | 8 | 9 | 10 | net9.0 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | all 26 | runtime; build; native; contentfiles; analyzers; buildtransitive 27 | 28 | 29 | 30 | 31 | 32 | -------------------------------------------------------------------------------- /Emulsion.Database/EmulsionDbContext.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Database 6 | 7 | open Microsoft.EntityFrameworkCore 8 | open Microsoft.EntityFrameworkCore.Design 9 | 10 | open Emulsion.Database.Entities 11 | 12 | type EmulsionDbContext(options: DbContextOptions) = 13 | inherit DbContext(options) 14 | 15 | [] val mutable private telegramContents: DbSet 16 | member this.TelegramContents with get() = this.telegramContents and set v = this.telegramContents <- v 17 | 18 | [] val mutable private archiveEntries: DbSet 19 | member this.ArchiveEntries with get() = this.archiveEntries and set v = this.archiveEntries <- v 20 | 21 | /// This type is used by the EFCore infrastructure when creating a new migration. 22 | type EmulsionDbContextDesignFactory() = 23 | interface IDesignTimeDbContextFactory with 24 | member this.CreateDbContext _ = 25 | let options = 26 | DbContextOptionsBuilder() 27 | .UseSqlite("Data Source=:memory:") 28 | .Options 29 | new EmulsionDbContext(options) 30 | -------------------------------------------------------------------------------- /Emulsion.Database/Entities.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Database.Entities 6 | 7 | open System 8 | open System.ComponentModel.DataAnnotations 9 | 10 | [] 11 | type TelegramContent = { 12 | [] Id: int64 13 | ChatId: int64 14 | ChatUserName: string 15 | MessageId: int64 16 | FileId: string 17 | FileName: string 18 | MimeType: string 19 | } 20 | 21 | [] 22 | type ArchiveEntry = { 23 | [] Id: int64 24 | MessageSystemId: string 25 | DateTime: DateTimeOffset 26 | Sender: string 27 | Text: string 28 | } 29 | -------------------------------------------------------------------------------- /Emulsion.Database/Migrations/20211026164449_Initial.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | // 6 | namespace Emulsion.Database.Migrations 7 | 8 | open System 9 | open Emulsion.Database 10 | open Microsoft.EntityFrameworkCore 11 | open Microsoft.EntityFrameworkCore.Infrastructure 12 | open Microsoft.EntityFrameworkCore.Migrations 13 | 14 | [)>] 15 | [] 16 | type Initial() = 17 | inherit Migration() 18 | 19 | override this.Up(migrationBuilder:MigrationBuilder) = 20 | migrationBuilder.CreateTable( 21 | name = "TelegramContents" 22 | ,columns = (fun table -> 23 | {| 24 | Id = 25 | table.Column( 26 | nullable = false 27 | ,``type`` = "INTEGER" 28 | ).Annotation("Sqlite:Autoincrement", true) 29 | ChatUserName = 30 | table.Column( 31 | nullable = true 32 | ,``type`` = "TEXT" 33 | ) 34 | MessageId = 35 | table.Column( 36 | nullable = false 37 | ,``type`` = "INTEGER" 38 | ) 39 | FileId = 40 | table.Column( 41 | nullable = true 42 | ,``type`` = "TEXT" 43 | ) 44 | |}) 45 | ,constraints = 46 | (fun table -> 47 | table.PrimaryKey("PK_TelegramContents", (fun x -> (x.Id) :> obj)) |> ignore 48 | ) 49 | ) |> ignore 50 | 51 | 52 | override this.Down(migrationBuilder:MigrationBuilder) = 53 | migrationBuilder.DropTable( 54 | name = "TelegramContents" 55 | ) |> ignore 56 | 57 | 58 | override this.BuildTargetModel(modelBuilder: ModelBuilder) = 59 | modelBuilder 60 | .HasAnnotation("ProductVersion", "5.0.10") 61 | |> ignore 62 | 63 | modelBuilder.Entity("Emulsion.Database.Models.TelegramContent", (fun b -> 64 | 65 | b.Property("Id") 66 | .IsRequired(true) 67 | .ValueGeneratedOnAdd() 68 | .HasColumnType("INTEGER") |> ignore 69 | b.Property("ChatUserName") 70 | .IsRequired(false) 71 | .HasColumnType("TEXT") |> ignore 72 | b.Property("FileId") 73 | .IsRequired(false) 74 | .HasColumnType("TEXT") |> ignore 75 | b.Property("MessageId") 76 | .IsRequired(true) 77 | .HasColumnType("INTEGER") |> ignore 78 | 79 | b.HasKey("Id") |> ignore 80 | 81 | b.ToTable("TelegramContents") |> ignore 82 | 83 | )) |> ignore 84 | 85 | -------------------------------------------------------------------------------- /Emulsion.Database/Migrations/20211031102019_TelegramContentUniqueConstraint.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | // 6 | namespace Emulsion.Database.Migrations 7 | 8 | open System 9 | open Emulsion.Database 10 | open Microsoft.EntityFrameworkCore 11 | open Microsoft.EntityFrameworkCore.Infrastructure 12 | open Microsoft.EntityFrameworkCore.Migrations 13 | 14 | [)>] 15 | [] 16 | type TelegramContentUniqueConstraint() = 17 | inherit Migration() 18 | 19 | override this.Up(migrationBuilder:MigrationBuilder) = 20 | migrationBuilder.Sql @" 21 | create unique index TelegramContents_Unique 22 | on TelegramContents(ChatUserName, MessageId, FileId) 23 | " |> ignore 24 | 25 | override this.Down(migrationBuilder:MigrationBuilder) = 26 | migrationBuilder.Sql @" 27 | drop index TelegramContents_Unique 28 | " |> ignore 29 | 30 | override this.BuildTargetModel(modelBuilder: ModelBuilder) = 31 | modelBuilder 32 | .HasAnnotation("ProductVersion", "5.0.10") 33 | |> ignore 34 | 35 | modelBuilder.Entity("Emulsion.Database.Entities.TelegramContent", (fun b -> 36 | 37 | b.Property("Id") 38 | .IsRequired(true) 39 | .ValueGeneratedOnAdd() 40 | .HasColumnType("INTEGER") |> ignore 41 | b.Property("ChatUserName") 42 | .IsRequired(false) 43 | .HasColumnType("TEXT") |> ignore 44 | b.Property("FileId") 45 | .IsRequired(false) 46 | .HasColumnType("TEXT") |> ignore 47 | b.Property("MessageId") 48 | .IsRequired(true) 49 | .HasColumnType("INTEGER") |> ignore 50 | 51 | b.HasKey("Id") |> ignore 52 | 53 | b.ToTable("TelegramContents") |> ignore 54 | 55 | )) |> ignore 56 | 57 | -------------------------------------------------------------------------------- /Emulsion.Database/Migrations/20220828133844_ContentFileNameAndMimeType.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | // 6 | namespace Emulsion.Database.Migrations 7 | 8 | open System 9 | open Emulsion.Database 10 | open Microsoft.EntityFrameworkCore 11 | open Microsoft.EntityFrameworkCore.Infrastructure 12 | open Microsoft.EntityFrameworkCore.Migrations 13 | 14 | [)>] 15 | [] 16 | type ContentFileNameAndMimeType() = 17 | inherit Migration() 18 | 19 | override this.Up(migrationBuilder:MigrationBuilder) = 20 | migrationBuilder.AddColumn( 21 | name = "FileName" 22 | ,table = "TelegramContents" 23 | ,``type`` = "TEXT" 24 | ,nullable = true 25 | ,defaultValue = "file.bin" 26 | ) |> ignore 27 | 28 | migrationBuilder.AddColumn( 29 | name = "MimeType" 30 | ,table = "TelegramContents" 31 | ,``type`` = "TEXT" 32 | ,nullable = true 33 | ,defaultValue = "application/octet-stream" 34 | ) |> ignore 35 | 36 | migrationBuilder.Sql @" 37 | drop index TelegramContents_Unique; 38 | 39 | create unique index TelegramContents_Unique 40 | on TelegramContents(ChatUserName, MessageId, FileId, FileName, MimeType) 41 | " |> ignore 42 | 43 | 44 | override this.Down(migrationBuilder:MigrationBuilder) = 45 | migrationBuilder.Sql @" 46 | drop index TelegramContents_Unique; 47 | 48 | create unique index TelegramContents_Unique 49 | on TelegramContents(ChatUserName, MessageId, FileId) 50 | " |> ignore 51 | 52 | migrationBuilder.DropColumn( 53 | name = "FileName" 54 | ,table = "TelegramContents" 55 | ) |> ignore 56 | 57 | migrationBuilder.DropColumn( 58 | name = "MimeType" 59 | ,table = "TelegramContents" 60 | ) |> ignore 61 | 62 | override this.BuildTargetModel(modelBuilder: ModelBuilder) = 63 | modelBuilder 64 | .HasAnnotation("ProductVersion", "5.0.10") 65 | |> ignore 66 | 67 | modelBuilder.Entity("Emulsion.Database.Entities.TelegramContent", (fun b -> 68 | 69 | b.Property("Id") 70 | .IsRequired(true) 71 | .ValueGeneratedOnAdd() 72 | .HasColumnType("INTEGER") |> ignore 73 | b.Property("ChatUserName") 74 | .IsRequired(false) 75 | .HasColumnType("TEXT") |> ignore 76 | b.Property("FileId") 77 | .IsRequired(false) 78 | .HasColumnType("TEXT") |> ignore 79 | b.Property("FileName") 80 | .IsRequired(false) 81 | .HasColumnType("TEXT") |> ignore 82 | b.Property("MessageId") 83 | .IsRequired(true) 84 | .HasColumnType("INTEGER") |> ignore 85 | b.Property("MimeType") 86 | .IsRequired(false) 87 | .HasColumnType("TEXT") |> ignore 88 | 89 | b.HasKey("Id") |> ignore 90 | 91 | b.ToTable("TelegramContents") |> ignore 92 | 93 | )) |> ignore 94 | 95 | -------------------------------------------------------------------------------- /Emulsion.Database/Migrations/20220828152910_ContentChatId.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | // 6 | namespace Emulsion.Database.Migrations 7 | 8 | open System 9 | open Emulsion.Database 10 | open Microsoft.EntityFrameworkCore 11 | open Microsoft.EntityFrameworkCore.Infrastructure 12 | open Microsoft.EntityFrameworkCore.Migrations 13 | 14 | [)>] 15 | [] 16 | type ContentChatId() = 17 | inherit Migration() 18 | 19 | override this.Up(migrationBuilder:MigrationBuilder) = 20 | migrationBuilder.AddColumn( 21 | name = "ChatId" 22 | ,table = "TelegramContents" 23 | ,``type`` = "INTEGER" 24 | ,nullable = false 25 | ,defaultValue = 0L 26 | ) |> ignore 27 | 28 | migrationBuilder.Sql @" 29 | drop index TelegramContents_Unique; 30 | 31 | create unique index TelegramContents_Unique 32 | on TelegramContents(ChatId, ChatUserName, MessageId, FileId, FileName, MimeType) 33 | " |> ignore 34 | 35 | override this.Down(migrationBuilder:MigrationBuilder) = 36 | migrationBuilder.Sql @" 37 | drop index TelegramContents_Unique; 38 | 39 | create unique index TelegramContents_Unique 40 | on TelegramContents(ChatUserName, MessageId, FileId, FileName, MimeType) 41 | " |> ignore 42 | 43 | migrationBuilder.DropColumn( 44 | name = "ChatId" 45 | ,table = "TelegramContents" 46 | ) |> ignore 47 | 48 | override this.BuildTargetModel(modelBuilder: ModelBuilder) = 49 | modelBuilder 50 | .HasAnnotation("ProductVersion", "5.0.10") 51 | |> ignore 52 | 53 | modelBuilder.Entity("Emulsion.Database.Entities.TelegramContent", (fun b -> 54 | 55 | b.Property("Id") 56 | .IsRequired(true) 57 | .ValueGeneratedOnAdd() 58 | .HasColumnType("INTEGER") |> ignore 59 | b.Property("ChatId") 60 | .IsRequired(true) 61 | .HasColumnType("INTEGER") |> ignore 62 | b.Property("ChatUserName") 63 | .IsRequired(false) 64 | .HasColumnType("TEXT") |> ignore 65 | b.Property("FileId") 66 | .IsRequired(false) 67 | .HasColumnType("TEXT") |> ignore 68 | b.Property("FileName") 69 | .IsRequired(false) 70 | .HasColumnType("TEXT") |> ignore 71 | b.Property("MessageId") 72 | .IsRequired(true) 73 | .HasColumnType("INTEGER") |> ignore 74 | b.Property("MimeType") 75 | .IsRequired(false) 76 | .HasColumnType("TEXT") |> ignore 77 | 78 | b.HasKey("Id") |> ignore 79 | 80 | b.ToTable("TelegramContents") |> ignore 81 | 82 | )) |> ignore 83 | 84 | -------------------------------------------------------------------------------- /Emulsion.Database/Migrations/20230625203424_ArchiveEntry.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | // 6 | namespace Emulsion.Database.Migrations 7 | 8 | open System 9 | open Emulsion.Database 10 | open Microsoft.EntityFrameworkCore 11 | open Microsoft.EntityFrameworkCore.Infrastructure 12 | open Microsoft.EntityFrameworkCore.Migrations 13 | 14 | [)>] 15 | [] 16 | type ArchiveEntry() = 17 | inherit Migration() 18 | 19 | override this.Up(migrationBuilder:MigrationBuilder) = 20 | migrationBuilder.CreateTable( 21 | name = "ArchiveEntries" 22 | ,columns = (fun table -> 23 | {| 24 | Id = 25 | table.Column( 26 | nullable = false 27 | ,``type`` = "INTEGER" 28 | ).Annotation("Sqlite:Autoincrement", true) 29 | MessageSystemId = 30 | table.Column( 31 | nullable = true 32 | ,``type`` = "TEXT" 33 | ) 34 | DateTime = 35 | table.Column( 36 | nullable = false 37 | ,``type`` = "TEXT" 38 | ) 39 | Sender = 40 | table.Column( 41 | nullable = true 42 | ,``type`` = "TEXT" 43 | ) 44 | Text = 45 | table.Column( 46 | nullable = true 47 | ,``type`` = "TEXT" 48 | ) 49 | |}) 50 | ,constraints = 51 | (fun table -> 52 | table.PrimaryKey("PK_ArchiveEntries", (fun x -> (x.Id) :> obj)) |> ignore 53 | ) 54 | ) |> ignore 55 | 56 | 57 | override this.Down(migrationBuilder:MigrationBuilder) = 58 | migrationBuilder.DropTable( 59 | name = "ArchiveEntries" 60 | ) |> ignore 61 | 62 | 63 | override this.BuildTargetModel(modelBuilder: ModelBuilder) = 64 | modelBuilder 65 | .HasAnnotation("ProductVersion", "5.0.10") 66 | |> ignore 67 | 68 | modelBuilder.Entity("Emulsion.Database.Entities.ArchiveEntry", (fun b -> 69 | 70 | b.Property("Id") 71 | .IsRequired(true) 72 | .ValueGeneratedOnAdd() 73 | .HasColumnType("INTEGER") |> ignore 74 | b.Property("DateTime") 75 | .IsRequired(true) 76 | .HasColumnType("TEXT") |> ignore 77 | b.Property("MessageSystemId") 78 | .IsRequired(false) 79 | .HasColumnType("TEXT") |> ignore 80 | b.Property("Sender") 81 | .IsRequired(false) 82 | .HasColumnType("TEXT") |> ignore 83 | b.Property("Text") 84 | .IsRequired(false) 85 | .HasColumnType("TEXT") |> ignore 86 | 87 | b.HasKey("Id") |> ignore 88 | 89 | b.ToTable("ArchiveEntries") |> ignore 90 | 91 | )) |> ignore 92 | 93 | modelBuilder.Entity("Emulsion.Database.Entities.TelegramContent", (fun b -> 94 | 95 | b.Property("Id") 96 | .IsRequired(true) 97 | .ValueGeneratedOnAdd() 98 | .HasColumnType("INTEGER") |> ignore 99 | b.Property("ChatId") 100 | .IsRequired(true) 101 | .HasColumnType("INTEGER") |> ignore 102 | b.Property("ChatUserName") 103 | .IsRequired(false) 104 | .HasColumnType("TEXT") |> ignore 105 | b.Property("FileId") 106 | .IsRequired(false) 107 | .HasColumnType("TEXT") |> ignore 108 | b.Property("FileName") 109 | .IsRequired(false) 110 | .HasColumnType("TEXT") |> ignore 111 | b.Property("MessageId") 112 | .IsRequired(true) 113 | .HasColumnType("INTEGER") |> ignore 114 | b.Property("MimeType") 115 | .IsRequired(false) 116 | .HasColumnType("TEXT") |> ignore 117 | 118 | b.HasKey("Id") |> ignore 119 | 120 | b.ToTable("TelegramContents") |> ignore 121 | 122 | )) |> ignore 123 | 124 | -------------------------------------------------------------------------------- /Emulsion.Database/Migrations/EmulsionDbContextModelSnapshot.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | // 6 | namespace Emulsion.Database.Migrations 7 | 8 | open System 9 | open Emulsion.Database 10 | open Microsoft.EntityFrameworkCore 11 | open Microsoft.EntityFrameworkCore.Infrastructure 12 | 13 | [)>] 14 | type EmulsionDbContextModelSnapshot() = 15 | inherit ModelSnapshot() 16 | 17 | override this.BuildModel(modelBuilder: ModelBuilder) = 18 | modelBuilder 19 | .HasAnnotation("ProductVersion", "5.0.10") 20 | |> ignore 21 | 22 | modelBuilder.Entity("Emulsion.Database.Entities.ArchiveEntry", (fun b -> 23 | 24 | b.Property("Id") 25 | .IsRequired(true) 26 | .ValueGeneratedOnAdd() 27 | .HasColumnType("INTEGER") |> ignore 28 | b.Property("DateTime") 29 | .IsRequired(true) 30 | .HasColumnType("TEXT") |> ignore 31 | b.Property("MessageSystemId") 32 | .IsRequired(false) 33 | .HasColumnType("TEXT") |> ignore 34 | b.Property("Sender") 35 | .IsRequired(false) 36 | .HasColumnType("TEXT") |> ignore 37 | b.Property("Text") 38 | .IsRequired(false) 39 | .HasColumnType("TEXT") |> ignore 40 | 41 | b.HasKey("Id") |> ignore 42 | 43 | b.ToTable("ArchiveEntries") |> ignore 44 | 45 | )) |> ignore 46 | 47 | modelBuilder.Entity("Emulsion.Database.Entities.TelegramContent", (fun b -> 48 | 49 | b.Property("Id") 50 | .IsRequired(true) 51 | .ValueGeneratedOnAdd() 52 | .HasColumnType("INTEGER") |> ignore 53 | b.Property("ChatId") 54 | .IsRequired(true) 55 | .HasColumnType("INTEGER") |> ignore 56 | b.Property("ChatUserName") 57 | .IsRequired(false) 58 | .HasColumnType("TEXT") |> ignore 59 | b.Property("FileId") 60 | .IsRequired(false) 61 | .HasColumnType("TEXT") |> ignore 62 | b.Property("FileName") 63 | .IsRequired(false) 64 | .HasColumnType("TEXT") |> ignore 65 | b.Property("MessageId") 66 | .IsRequired(true) 67 | .HasColumnType("INTEGER") |> ignore 68 | b.Property("MimeType") 69 | .IsRequired(false) 70 | .HasColumnType("TEXT") |> ignore 71 | 72 | b.HasKey("Id") |> ignore 73 | 74 | b.ToTable("TelegramContents") |> ignore 75 | 76 | )) |> ignore 77 | 78 | -------------------------------------------------------------------------------- /Emulsion.Database/QueryableEx.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Database.QueryableEx 6 | 7 | open System.Linq 8 | 9 | open Microsoft.EntityFrameworkCore 10 | 11 | let tryExactlyOneAsync<'a>(source: IQueryable<'a>): Async<'a option> = async { 12 | let! ct = Async.CancellationToken 13 | let! item = Async.AwaitTask(EntityFrameworkQueryableExtensions.SingleOrDefaultAsync(source, ct)) 14 | 15 | // We cannot use Option.ofObj here since not every entity type can be marked with AllowNullLiteral. 16 | match box item with 17 | | null -> return None 18 | | _ -> return Some item 19 | } 20 | 21 | let exactlyOneAsync<'a>(source: IQueryable<'a>): Async<'a> = async { 22 | let! ct = Async.CancellationToken 23 | return! Async.AwaitTask(EntityFrameworkQueryableExtensions.SingleAsync(source, ct)) 24 | } 25 | -------------------------------------------------------------------------------- /Emulsion.MessageArchive.Frontend/Emulsion.MessageArchive.Frontend.proj: -------------------------------------------------------------------------------- 1 | 6 | 7 | 8 | 9 | 10 | net9.0 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 25 | 26 | 27 | 28 | 29 | 32 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /Emulsion.MessageArchive.Frontend/api.d.ts: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | type Statistics = { 6 | messageCount: number; 7 | } 8 | 9 | type Message = { 10 | messageSystemId: string; 11 | sender: string; 12 | dateTime: string; 13 | text: string; 14 | } 15 | -------------------------------------------------------------------------------- /Emulsion.MessageArchive.Frontend/app.tsx: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | import React, {useState} from 'react'; 6 | import {render} from 'react-dom'; 7 | 8 | class LoadedPage { 9 | constructor( 10 | public readonly limit: number, 11 | public readonly statistics: Statistics, 12 | public readonly pageIndex: number, 13 | public readonly messages: Message[] 14 | ) {} 15 | } 16 | 17 | class ErrorState { 18 | constructor(public readonly error: string) {} 19 | } 20 | 21 | type State = 'Loading' | LoadedPage | ErrorState; 22 | 23 | const getStatistics = async (): Promise => { 24 | let url = window.location.href 25 | url = url.substring(0, url.lastIndexOf('/')); 26 | 27 | let response = await fetch(`${url}/api/history/statistics`); 28 | return await response.json(); 29 | }; 30 | 31 | const getMessages = async (offset: number, limit: number): Promise => { 32 | let url = window.location.href 33 | url = url.substring(0, url.lastIndexOf('/')); 34 | 35 | let response = await fetch(`${url}/api/history/messages?offset=${offset}&limit=${limit}`); 36 | return await response.json(); 37 | } 38 | 39 | const getPage = async (pageIndex: number, limit: number): Promise => { 40 | const offset = pageIndex * limit; 41 | const statistics = await getStatistics(); 42 | const messages = await getMessages(offset, limit); 43 | return new LoadedPage(limit, statistics, pageIndex, messages); 44 | } 45 | 46 | const loadPage = (index: number, limit: number, setState: (state: State) => void) => { 47 | getPage(index, limit) 48 | .then(page => setState(page)) 49 | .catch(error => setState(new ErrorState(error.message))); 50 | } 51 | 52 | const LimitControl = ({limit, onChange}: {limit: number, onChange: (limit: number) => void}) => { 53 | const values = [ 54 | 25, 55 | 50, 56 | 100, 57 | 500 58 | ] 59 | return 62 | }; 63 | 64 | const PageControls = ({page, setState}: {page: LoadedPage, setState: (state: State) => void}) => { 65 | const lastPageNumber= Math.ceil(page.statistics.messageCount / page.limit); 66 | const lastPageIndex= lastPageNumber - 1; 67 | return <> 68 | Count: {page.statistics.messageCount}
69 | Page: {page.pageIndex + 1} of {Math.ceil(page.statistics.messageCount / page.limit)}
70 | Show messages per page: loadPage(0, limit, setState)}/>
71 | 72 | 73 | 74 | 75 | ; 76 | } 77 | 78 | const dateTimeToText = (dateTime: string) => { 79 | const fullText = new Date(dateTime).toISOString(); 80 | return fullText.substring(0, fullText.lastIndexOf('.')) + 'Z'; 81 | } 82 | 83 | const renderMessageText = (text: string) => { 84 | const lines= text.split('\n'); 85 | return lines.map((line) =>

{line}

); 86 | } 87 | 88 | const renderMessage = (message: Message) =>
89 |
{dateTimeToText(message.dateTime)}
90 |
{message.sender}
91 |
{renderMessageText(message.text)}
92 |
93 | 94 | const MessageList = ({list}: {list: Message[]}) =>
95 | {list.map(renderMessage)} 96 |
; 97 | 98 | const App = () => { 99 | const [state, setState] = useState('Loading'); 100 | if (state === 'Loading') { 101 | loadPage(0, 100, setState) 102 | } 103 | 104 | if (state === 'Loading') { 105 | return
Loading…
106 | } else if (state instanceof ErrorState) { 107 | return
Error: {state.error}
108 | } else { 109 | return
110 | 111 | 112 |
113 | } 114 | }; 115 | 116 | render(, document.getElementById('app')); 117 | -------------------------------------------------------------------------------- /Emulsion.MessageArchive.Frontend/index.html: -------------------------------------------------------------------------------- 1 | 6 | 7 | 8 | 9 | Emulsion Message Archive 10 | 11 | 12 | 13 | 14 |
15 | 16 | 17 | -------------------------------------------------------------------------------- /Emulsion.MessageArchive.Frontend/package-lock.json.license: -------------------------------------------------------------------------------- 1 | SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | 3 | SPDX-License-Identifier: MIT 4 | -------------------------------------------------------------------------------- /Emulsion.MessageArchive.Frontend/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "scripts": { 3 | "build": "parcel build --public-url ./ --cache-dir obj/.parcel-cache --dist-dir bin" 4 | }, 5 | "source": "index.html", 6 | "type": "module", 7 | "devDependencies": { 8 | "@parcel/transformer-less": "^2.9.3", 9 | "@types/react": "^19.0.0", 10 | "@types/react-dom": "^19.0.0", 11 | "parcel": "^2.9.3", 12 | "process": "^0.11.10", 13 | "react": "^19.0.0", 14 | "react-dom": "^19.0.0", 15 | "typescript": "^5.1.6" 16 | } 17 | } 18 | -------------------------------------------------------------------------------- /Emulsion.MessageArchive.Frontend/package.json.license: -------------------------------------------------------------------------------- 1 | SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | 3 | SPDX-License-Identifier: MIT 4 | -------------------------------------------------------------------------------- /Emulsion.MessageArchive.Frontend/style.less: -------------------------------------------------------------------------------- 1 | /* 2 | * SPDX-FileCopyrightText: 2024 Emulsion contributors 3 | * 4 | * SPDX-License-Identifier: MIT 5 | */ 6 | 7 | .message { 8 | .dateTime, .sender, .text { display: inline-block; } 9 | .dateTime { 10 | color: #AAA; 11 | } 12 | .sender { 13 | margin: 0 0.5em; 14 | font-weight: bold; 15 | } 16 | .text { 17 | vertical-align: top; 18 | p { margin: 0; } 19 | } 20 | } 21 | -------------------------------------------------------------------------------- /Emulsion.MessageArchive.Frontend/tsconfig.json: -------------------------------------------------------------------------------- 1 | { 2 | "compilerOptions": { 3 | "target": "es2016", 4 | "module": "esnext", 5 | "forceConsistentCasingInFileNames": true, 6 | "jsx": "react", 7 | "strict": true, 8 | "skipLibCheck": true, 9 | "noEmitOnError": true, 10 | "allowSyntheticDefaultImports": true 11 | } 12 | } 13 | -------------------------------------------------------------------------------- /Emulsion.MessageArchive.Frontend/tsconfig.json.license: -------------------------------------------------------------------------------- 1 | SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | 3 | SPDX-License-Identifier: MIT 4 | -------------------------------------------------------------------------------- /Emulsion.Messaging/AssemblyInfo.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Messaging 6 | 7 | open System.Runtime.CompilerServices 8 | 9 | [] 10 | () 11 | -------------------------------------------------------------------------------- /Emulsion.Messaging/Emulsion.Messaging.fsproj: -------------------------------------------------------------------------------- 1 | 6 | 7 | 8 | 9 | net9.0 10 | true 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /Emulsion.Messaging/Message.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Messaging 6 | 7 | [] 8 | type AuthoredMessage = { 9 | author: string 10 | text: string 11 | } 12 | 13 | [] 14 | type EventMessage = { 15 | text: string 16 | } 17 | 18 | type Message = 19 | | Authored of AuthoredMessage 20 | | Event of EventMessage 21 | 22 | module Message = 23 | let text = function 24 | | Authored msg -> msg.text 25 | | Event msg -> msg.text 26 | 27 | type OutgoingMessage = 28 | | OutgoingMessage of Message 29 | 30 | type IncomingMessage = 31 | | XmppMessage of Message 32 | | TelegramMessage of Message 33 | -------------------------------------------------------------------------------- /Emulsion.Messaging/MessageSender.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Messaging.MessageSender 6 | 7 | open System 8 | open System.Threading 9 | 10 | open FSharpx.Collections 11 | open Serilog 12 | 13 | type MessageSenderContext = { 14 | Send: OutgoingMessage -> Async 15 | Logger: ILogger 16 | RestartCooldown: TimeSpan 17 | } 18 | 19 | type private State = { 20 | Messages: Queue 21 | ClientReadyToSendMessages: bool 22 | } with static member initial = { Messages = Queue.empty; ClientReadyToSendMessages = false } 23 | 24 | let private trySendMessage ctx msg = async { 25 | try 26 | do! ctx.Send msg 27 | return true 28 | with 29 | | ex -> 30 | ctx.Logger.Error(ex, "Error when trying to send message {Message}", msg) 31 | return false 32 | } 33 | 34 | let private tryProcessTopMessage ctx (state: State) = async { 35 | if not state.ClientReadyToSendMessages then 36 | return state 37 | else 38 | match state.Messages with 39 | | Queue.Nil -> return state 40 | | Queue.Cons(message, rest) -> 41 | let! success = trySendMessage ctx message 42 | if not success then 43 | ctx.Logger.Information("Waiting for {RestartCooldown} to resume processing output message queue", 44 | ctx.RestartCooldown) 45 | do! Async.Sleep(int ctx.RestartCooldown.TotalMilliseconds) 46 | let newState = 47 | if success 48 | then { state with Messages = rest } 49 | else state // leave the message in the queue 50 | return newState 51 | } 52 | 53 | type Event = 54 | | QueueMessage of OutgoingMessage 55 | | SetReceiveStatus of bool 56 | 57 | let private updateState state msg = 58 | match msg with 59 | | QueueMessage m -> 60 | let newMessages = Queue.conj m state.Messages 61 | { state with Messages = newMessages } 62 | | SetReceiveStatus status -> 63 | { state with ClientReadyToSendMessages = status } 64 | 65 | type Sender = MailboxProcessor 66 | let internal receiver (ctx: MessageSenderContext) (inbox: Sender): Async = 67 | let rec loop (state: State) = async { 68 | ctx.Logger.Debug("Current queue state: {State}", state) 69 | 70 | let blockAndProcessNextIncomingMessage() = async { 71 | let! msg = inbox.Receive() 72 | return! loop (updateState state msg) 73 | } 74 | 75 | // Always process the incoming queue first if there're anything there: 76 | match! inbox.TryReceive 0 with 77 | | Some msg -> 78 | return! loop (updateState state msg) 79 | | None -> 80 | match state.ClientReadyToSendMessages, state.Messages with 81 | | false, _ -> // We aren't permitted to send any messages, we have nothing other to do than block on the 82 | // message queue. 83 | return! blockAndProcessNextIncomingMessage() 84 | | true, Queue.Cons _ -> // We're permitted to send a message and the queue is not empty. 85 | let! newState = tryProcessTopMessage ctx state 86 | return! loop newState 87 | | true, Queue.Nil -> // We're allowed to send a message, but the queue is empty. We have nothing to send, 88 | // thus we have nothing to do other than to block on the message queue. 89 | return! blockAndProcessNextIncomingMessage() 90 | } 91 | loop State.initial 92 | 93 | let startActivity(ctx: MessageSenderContext, token: CancellationToken): Sender = 94 | let processor = MailboxProcessor.Start(receiver ctx, token) 95 | processor.Error.Add(fun ex -> ctx.Logger.Error(ex, "Error observed by the message sender mailbox")) 96 | processor 97 | 98 | let setReadyToAcceptMessages(activity: Sender): bool -> unit = SetReceiveStatus >> activity.Post 99 | let send(activity: Sender): OutgoingMessage -> unit = QueueMessage >> activity.Post 100 | -------------------------------------------------------------------------------- /Emulsion.Messaging/MessageSystem.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Messaging.MessageSystem 6 | 7 | open System 8 | open System.Threading 9 | 10 | open Serilog 11 | 12 | type IncomingMessageReceiver = IncomingMessage -> unit 13 | 14 | /// The IM message queue. Manages the underlying connection, reconnects when necessary, stores the outgoing messages in 15 | /// a queue and sends them when possible. Redirects the incoming messages to a function passed when starting the queue. 16 | type IMessageSystem = 17 | /// Starts the IM connection, manages reconnects. Never terminates unless cancelled. 18 | abstract member RunSynchronously : IncomingMessageReceiver -> unit 19 | 20 | /// Queues the message to be sent to the IM system when possible. 21 | abstract member PutMessage : OutgoingMessage -> unit 22 | 23 | type ServiceContext = { 24 | RestartCooldown: TimeSpan 25 | Logger: ILogger 26 | } 27 | 28 | let internal wrapRun (ctx: ServiceContext) (runAsync: Async) : Async = 29 | async { 30 | while true do 31 | try 32 | do! runAsync 33 | with 34 | | :? OperationCanceledException -> return () 35 | | ex -> 36 | ctx.Logger.Error(ex, "Non-terminating message system error") 37 | ctx.Logger.Information("Waiting for {RestartCooldown} to restart the message system", 38 | ctx.RestartCooldown) 39 | do! Async.Sleep(int ctx.RestartCooldown.TotalMilliseconds) 40 | } 41 | 42 | let putMessage (messageSystem: IMessageSystem) (message: OutgoingMessage) = 43 | messageSystem.PutMessage message 44 | 45 | [] 46 | type MessageSystemBase(ctx: ServiceContext, cancellationToken: CancellationToken) as this = 47 | let sender = MessageSender.startActivity({ 48 | Send = this.Send 49 | Logger = ctx.Logger 50 | RestartCooldown = ctx.RestartCooldown 51 | }, cancellationToken) 52 | 53 | /// Implements the two-phase run protocol. 54 | /// 55 | /// First, the parent async workflow resolves when the connection has been established, and the system is ready to 56 | /// receive outgoing messages. 57 | /// 58 | /// The nested async workflow is a message loop inside of a system. While this second workflow is executing, the 59 | /// system is expected to receive the messages. 60 | /// 61 | /// Any of these workflows could either throw OperationCanceledException or return a unit on cancellation. 62 | /// 63 | /// This method will never be called multiple times in parallel on a single instance. 64 | abstract member RunUntilError : IncomingMessageReceiver -> Async> 65 | 66 | /// Sends a message through the message system. Free-threaded. Could throw exceptions; if throws an exception, then 67 | /// will be restarted later. 68 | abstract member Send : OutgoingMessage -> Async 69 | 70 | /// Runs the message system loop asynchronously. Should never terminate unless cancelled. 71 | abstract member RunAsync : IncomingMessageReceiver -> Async 72 | default _.RunAsync receiver = async { 73 | // While this line executes, the system isn't yet started and isn't ready to accept the messages: 74 | let! runLoop = this.RunUntilError receiver 75 | MessageSender.setReadyToAcceptMessages sender true 76 | try 77 | do! runLoop 78 | finally 79 | MessageSender.setReadyToAcceptMessages sender false 80 | } 81 | 82 | interface IMessageSystem with 83 | member _.RunSynchronously receiver = 84 | let runner = this.RunAsync receiver 85 | Async.RunSynchronously(wrapRun ctx runner, cancellationToken = cancellationToken) 86 | 87 | member _.PutMessage message = 88 | MessageSender.send sender message 89 | -------------------------------------------------------------------------------- /Emulsion.Settings/Emulsion.Settings.fsproj: -------------------------------------------------------------------------------- 1 | 6 | 7 | 8 | 9 | 10 | net9.0 11 | true 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /Emulsion.Settings/Settings.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Settings 6 | 7 | open System 8 | open System.Globalization 9 | 10 | open Microsoft.Extensions.Configuration 11 | 12 | open Emulsion.Database 13 | 14 | type XmppSettings = { 15 | Login: string 16 | Password: string 17 | Room: string 18 | RoomPassword: string option 19 | Nickname: string 20 | ConnectionTimeout: TimeSpan 21 | MessageTimeout: TimeSpan 22 | PingInterval: TimeSpan option 23 | PingTimeout: TimeSpan 24 | } 25 | 26 | type TelegramSettings = { 27 | Token: string 28 | GroupId: int64 29 | MessageThreadId: int64 option 30 | } 31 | 32 | type LogSettings = { 33 | Directory: string 34 | } 35 | 36 | type HostingSettings = { 37 | ExternalUriBase: Uri 38 | BindUri: string 39 | HashIdSalt: string 40 | } 41 | 42 | type FileCacheSettings = { 43 | Directory: string 44 | FileSizeLimitBytes: uint64 45 | TotalCacheSizeLimitBytes: uint64 46 | } 47 | 48 | type MessageArchiveSettings = { 49 | IsEnabled: bool 50 | } 51 | 52 | type EmulsionSettings = { 53 | Xmpp: XmppSettings 54 | Telegram: TelegramSettings 55 | Log: LogSettings 56 | Database: DatabaseSettings option 57 | Hosting: HostingSettings option 58 | FileCache: FileCacheSettings option 59 | MessageArchive: MessageArchiveSettings 60 | } 61 | 62 | let defaultConnectionTimeout = TimeSpan.FromMinutes 5.0 63 | let defaultMessageTimeout = TimeSpan.FromMinutes 5.0 64 | let defaultPingTimeout = TimeSpan.FromSeconds 30.0 65 | 66 | let private readTimeSpanOpt key (section: IConfigurationSection) = 67 | section[key] 68 | |> Option.ofObj 69 | |> Option.map (fun s -> TimeSpan.Parse(s, CultureInfo.InvariantCulture)) 70 | 71 | let private readTimeSpan defaultVal key section = 72 | readTimeSpanOpt key section 73 | |> Option.defaultValue defaultVal 74 | 75 | let read (config : IConfiguration) : EmulsionSettings = 76 | let boolOpt: string -> bool option = Option.ofObj >> Option.map bool.Parse 77 | let int64Opt: string -> int64 option = Option.ofObj >> Option.map int64 78 | let uint64OrDefault value ``default`` = 79 | value 80 | |> Option.ofObj 81 | |> Option.map uint64 82 | |> Option.defaultValue ``default`` 83 | 84 | let readXmpp (section : IConfigurationSection) = { 85 | Login = section["login"] 86 | Password = section["password"] 87 | Room = section["room"] 88 | RoomPassword = Option.ofObj section["roomPassword"] 89 | Nickname = section["nickname"] 90 | ConnectionTimeout = readTimeSpan defaultConnectionTimeout "connectionTimeout" section 91 | MessageTimeout = readTimeSpan defaultMessageTimeout "messageTimeout" section 92 | PingInterval = readTimeSpanOpt "pingInterval" section 93 | PingTimeout = readTimeSpan defaultPingTimeout "pingTimeout" section 94 | } 95 | let readTelegram (section : IConfigurationSection) = { 96 | Token = section["token"] 97 | GroupId = int64 section["groupId"] 98 | MessageThreadId = int64Opt section["messageThreadId"] 99 | } 100 | let readLog(section: IConfigurationSection) = { 101 | Directory = section["directory"] 102 | } 103 | let readDatabase(section: IConfigurationSection) = 104 | section["dataSource"] 105 | |> Option.ofObj 106 | |> Option.map(fun dataSource -> { DataSource = dataSource }) 107 | let readHosting(section: IConfigurationSection) = 108 | let externalUriBase = Option.ofObj section["externalUriBase"] 109 | let bindUri = Option.ofObj section["bindUri"] 110 | let hashIdSalt = Option.ofObj section["hashIdSalt"] 111 | match externalUriBase, bindUri, hashIdSalt with 112 | | Some externalUriBase, Some bindUri, Some hashIdSalt -> 113 | Some { 114 | ExternalUriBase = Uri externalUriBase 115 | BindUri = bindUri 116 | HashIdSalt = hashIdSalt 117 | } 118 | | None, None, None -> None 119 | | other -> failwith $"Parameter pack {other} represents invalid hosting settings." 120 | let readFileCache(section: IConfigurationSection) = 121 | Option.ofObj section["directory"] 122 | |> Option.map(fun directory -> { 123 | Directory = directory 124 | FileSizeLimitBytes = uint64OrDefault section["fileSizeLimitBytes"] (1024UL * 1024UL) 125 | TotalCacheSizeLimitBytes = uint64OrDefault section["totalCacheSizeLimitBytes"] (20UL * 1024UL * 1024UL) 126 | }) 127 | let readMessageArchive(section: IConfigurationSection) = 128 | Option.ofObj section 129 | |> Option.map(fun section -> { 130 | IsEnabled = section["isEnabled"] |> boolOpt |> Option.defaultValue false 131 | }) 132 | |> Option.defaultValue { IsEnabled = false } 133 | 134 | { Xmpp = readXmpp <| config.GetSection("xmpp") 135 | Telegram = readTelegram <| config.GetSection("telegram") 136 | Log = readLog <| config.GetSection "log" 137 | Database = readDatabase <| config.GetSection "database" 138 | Hosting = readHosting <| config.GetSection "hosting" 139 | FileCache = readFileCache <| config.GetSection "fileCache" 140 | MessageArchive = readMessageArchive <| config.GetSection "messageArchive" } 141 | 142 | -------------------------------------------------------------------------------- /Emulsion.Telegram/AssemblyInfo.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Telegram 6 | 7 | open System.Runtime.CompilerServices 8 | 9 | [] 10 | () 11 | -------------------------------------------------------------------------------- /Emulsion.Telegram/Client.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Telegram 6 | 7 | open System 8 | open System.Threading 9 | 10 | open Emulsion.Database 11 | open Emulsion.Messaging.MessageSystem 12 | open Emulsion.Settings 13 | 14 | type FileInfo = { 15 | TemporaryLink: Uri 16 | Size: uint64 17 | } 18 | 19 | type ITelegramClient = 20 | abstract GetFileInfo: fileId: string -> Async 21 | 22 | type Client(ctx: ServiceContext, 23 | cancellationToken: CancellationToken, 24 | telegramSettings: TelegramSettings, 25 | databaseSettings: DatabaseSettings option, 26 | hostingSettings: HostingSettings option) = 27 | inherit MessageSystemBase(ctx, cancellationToken) 28 | 29 | let botConfig = { 30 | Funogram.Telegram.Bot.Config.defaultConfig with 31 | Token = telegramSettings.Token 32 | OnError = fun e -> ctx.Logger.Error(e, "Exception in Telegram message processing") 33 | } 34 | 35 | interface ITelegramClient with 36 | member this.GetFileInfo(fileId) = async { 37 | let logger = ctx.Logger 38 | logger.Information("Querying file information for file {FileId}", fileId) 39 | let! file = Funogram.sendGetFile botConfig fileId 40 | match file.FilePath, file.FileSize with 41 | | None, None -> 42 | logger.Warning("File {FileId} was not found on server", fileId) 43 | return None 44 | | Some fp, Some sz -> 45 | return Some { 46 | TemporaryLink = Uri $"https://api.telegram.org/file/bot{telegramSettings.Token}/{fp}" 47 | Size = Checked.uint64 sz 48 | } 49 | | x, y -> return failwith $"Unknown data received from Telegram server: {x}, {y}" 50 | } 51 | 52 | override _.RunUntilError receiver = async { 53 | // Run loop of Telegram is in no need of any complicated start, so just return an async that will perform it: 54 | return Funogram.run ctx.Logger telegramSettings databaseSettings hostingSettings botConfig receiver 55 | } 56 | 57 | override _.Send message = 58 | Funogram.sendMessage telegramSettings botConfig message 59 | -------------------------------------------------------------------------------- /Emulsion.Telegram/Emulsion.Telegram.fsproj: -------------------------------------------------------------------------------- 1 | 6 | 7 | 8 | 9 | net9.0 10 | true 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /Emulsion.Telegram/Html.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Telegram.Html 6 | 7 | /// HTML escaping for Telegram only. According to the docs: https://core.telegram.org/bots/api#html-style 8 | let escape : string -> string = 9 | String.collect(function 10 | | '<' -> "<" 11 | | '>' -> ">" 12 | | '&' -> "&" 13 | | other -> string other) 14 | -------------------------------------------------------------------------------- /Emulsion.Telegram/LinkGenerator.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | /// A module that generates links to various content from Telegram. 6 | module Emulsion.Telegram.LinkGenerator 7 | 8 | open System 9 | 10 | open Funogram.Telegram.Types 11 | open Serilog 12 | 13 | open Emulsion.ContentProxy 14 | open Emulsion.Database 15 | open Emulsion.Settings 16 | 17 | type FunogramMessage = Funogram.Telegram.Types.Message 18 | 19 | type TelegramThreadLinks = { 20 | ContentLinks: Uri seq 21 | ReplyToContentLinks: Uri seq 22 | } 23 | 24 | let private getMessageLink (message: FunogramMessage) = 25 | match message with 26 | | { MessageId = id 27 | Chat = { Type = SuperGroup 28 | Username = Some chatName } } -> 29 | Some <| Uri $"https://t.me/{chatName}/{id}" 30 | | _ -> None 31 | 32 | let private gatherMessageLink(message: FunogramMessage) = 33 | match message with 34 | | { Text = Some _} | { Poll = Some _ } -> None 35 | | _ -> getMessageLink message 36 | 37 | type private FileInfo = { 38 | FileId: string 39 | FileName: string option 40 | MimeType: string option 41 | } 42 | 43 | type private WithId<'T when 'T: (member FileId: string)> = 'T 44 | type private WithFileName<'T when 'T: (member FileName: string option)> = 'T 45 | type private WithMimeType<'T when 'T: (member MimeType: string option)> = 'T 46 | 47 | let inline private extractFileInfo<'T 48 | when WithId<'T> 49 | and WithFileName<'T> 50 | and WithMimeType<'T>> 51 | : 'T option -> FileInfo option = 52 | Option.map(fun file -> { 53 | FileId = file.FileId 54 | FileName = file.FileName 55 | MimeType = file.MimeType 56 | }) 57 | 58 | let inline private extractFileInfoWithName<'T 59 | when WithId<'T> 60 | and WithMimeType<'T>> 61 | (fileName: string) 62 | : 'T option -> FileInfo option = 63 | Option.map(fun file -> { 64 | FileId = file.FileId 65 | FileName = Some fileName 66 | MimeType = file.MimeType 67 | }) 68 | 69 | let inline private extractFileInfoWithNameAndMimeType<'T when WithId<'T>> 70 | (fileName: string) 71 | (mimeType: string) 72 | : 'T option -> FileInfo option = 73 | Option.map(fun file -> { 74 | FileId = file.FileId 75 | FileName = Some fileName 76 | MimeType = Some mimeType 77 | }) 78 | 79 | let private extractPhotoFileInfo: PhotoSize[] option -> FileInfo option = 80 | Option.bind( 81 | // Telegram may send several differently-sized thumbnails in one message. Pick the biggest one of them. 82 | Seq.sortByDescending(fun size -> size.Height * size.Width) 83 | >> Seq.map(fun photoSize -> photoSize.FileId) 84 | >> Seq.tryHead 85 | >> Option.map(fun fileId -> { 86 | FileId = fileId 87 | FileName = Some "photo.jpg" 88 | MimeType = Some "image/jpeg" 89 | }) 90 | ) 91 | 92 | let private extractStickerFileInfo: Sticker option -> FileInfo option = 93 | Option.bind(fun sticker -> 94 | if sticker.IsAnimated then 95 | // We cannot to preview Telegram's .tgs stickers in browser, so return thumbnail 96 | extractFileInfoWithNameAndMimeType "sticker.webp" "image/webp" sticker.Thumbnail 97 | elif sticker.IsVideo then 98 | extractFileInfoWithNameAndMimeType "sticker.webm" "video/webm" (Some sticker) 99 | else 100 | extractFileInfoWithNameAndMimeType "sticker.webp" "image/webp" (Some sticker) 101 | ) 102 | 103 | let private getFileInfos(message: FunogramMessage): FileInfo seq = 104 | Seq.choose id <| seq { 105 | extractFileInfo message.Document 106 | extractFileInfo message.Audio 107 | extractFileInfo message.Animation 108 | extractPhotoFileInfo message.Photo 109 | extractStickerFileInfo message.Sticker 110 | extractFileInfo message.Video 111 | extractFileInfoWithName "voice.ogg" message.Voice 112 | extractFileInfoWithNameAndMimeType "video.mp4" "video/mp4" message.VideoNote 113 | } 114 | 115 | 116 | let private getContentIdentities(message: FunogramMessage): ContentStorage.MessageContentIdentity seq = 117 | getFileInfos message 118 | |> Seq.map (fun fileInfo -> 119 | { 120 | ChatId = message.Chat.Id 121 | ChatUserName = Option.defaultValue "" message.Chat.Username 122 | MessageId = message.MessageId 123 | FileId = fileInfo.FileId 124 | FileName = Option.defaultValue "file.bin" fileInfo.FileName 125 | MimeType = Option.defaultValue "application/octet-stream" fileInfo.MimeType 126 | } 127 | ) 128 | 129 | let gatherLinks (logger: ILogger) 130 | (databaseSettings: DatabaseSettings option) 131 | (hostingSettings: HostingSettings option) 132 | (message: FunogramMessage): Async = async { 133 | let getMessageBodyLinks message: Async = 134 | match databaseSettings, hostingSettings with 135 | | Some databaseSettings, Some hostingSettings -> 136 | async { 137 | let! links = 138 | getContentIdentities message 139 | |> Seq.map(fun identity -> async { 140 | let! content = DataStorage.transaction databaseSettings (fun ctx -> 141 | ContentStorage.getOrCreateMessageRecord ctx identity 142 | ) 143 | 144 | let hashId = Proxy.encodeHashId hostingSettings.HashIdSalt content.Id 145 | return Proxy.getLink hostingSettings.ExternalUriBase hashId 146 | }) 147 | |> Async.Parallel 148 | return links 149 | } 150 | | _ -> 151 | let link = gatherMessageLink message 152 | async.Return(Option.toList link) 153 | 154 | try 155 | let! contentLink = getMessageBodyLinks message 156 | let! replyToContentLink = 157 | match message.ReplyToMessage with 158 | | None -> async.Return Seq.empty 159 | | Some replyTo -> getMessageBodyLinks replyTo 160 | return { 161 | ContentLinks = contentLink 162 | ReplyToContentLinks = replyToContentLink 163 | } 164 | with 165 | | ex -> 166 | logger.Error(ex, "Error while trying to generate links for message.") 167 | return { 168 | ContentLinks = Seq.empty 169 | ReplyToContentLinks = Seq.empty 170 | } 171 | } 172 | -------------------------------------------------------------------------------- /Emulsion.TestFramework/Emulsion.TestFramework.fsproj: -------------------------------------------------------------------------------- 1 | 6 | 7 | 8 | 9 | 10 | net9.0 11 | true 12 | Library 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /Emulsion.TestFramework/Exceptions.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.TestFramework.Exceptions 6 | 7 | open System 8 | open Microsoft.EntityFrameworkCore 9 | 10 | let rec unwrap<'a when 'a :> Exception>(ex: Exception): 'a = 11 | match ex with 12 | | :? 'a as ex -> ex 13 | | :? AggregateException as ax when ax.InnerExceptions.Count = 1 -> unwrap(Seq.exactlyOne ax.InnerExceptions) 14 | | :? DbUpdateException as dx when not(isNull dx.InnerException) -> unwrap dx.InnerException 15 | | _ -> failwithf $"Unable to unwrap the following exception into {typeof<'a>.FullName}:\n{ex}" 16 | -------------------------------------------------------------------------------- /Emulsion.TestFramework/FileCacheUtil.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.TestFramework.FileCacheUtil 6 | 7 | open System.IO 8 | 9 | open Emulsion.ContentProxy 10 | open Emulsion.Settings 11 | open Emulsion.TestFramework.Logging 12 | 13 | let newCacheDirectory() = 14 | let path = Path.GetTempFileName() 15 | File.Delete path 16 | Directory.CreateDirectory path |> ignore 17 | path 18 | 19 | let setUpFileCache outputHelper sha256 cacheDirectory (totalLimitBytes: uint64) = 20 | let settings = { 21 | Directory = cacheDirectory 22 | FileSizeLimitBytes = 10UL * 1024UL * 1024UL 23 | TotalCacheSizeLimitBytes = totalLimitBytes 24 | } 25 | 26 | new FileCache(xunitLogger outputHelper, settings, SimpleHttpClientFactory(), sha256) 27 | -------------------------------------------------------------------------------- /Emulsion.TestFramework/Lifetimes.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.TestFramework.Lifetimes 6 | 7 | open System 8 | open System.Threading.Tasks 9 | open JetBrains.Lifetimes 10 | 11 | let WaitForTermination (lt: Lifetime) (timeout: TimeSpan) (message: string): Task = 12 | let tcs = TaskCompletionSource() 13 | lt.OnTermination tcs.SetResult |> ignore 14 | let delay = Task.Delay timeout 15 | task { 16 | let! earlier = Task.WhenAny(delay, tcs.Task) 17 | if earlier <> tcs.Task && not tcs.Task.IsCompleted then 18 | failwith message 19 | } 20 | -------------------------------------------------------------------------------- /Emulsion.TestFramework/LockedBuffer.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.TestFramework 6 | 7 | type LockedBuffer<'T>() = 8 | let messages = ResizeArray<'T>() 9 | member _.Add(m: 'T) = 10 | lock messages (fun () -> 11 | messages.Add m 12 | ) 13 | member _.Count(): int = 14 | lock messages (fun () -> 15 | messages.Count 16 | ) 17 | member _.All(): 'T seq = 18 | ResizeArray messages 19 | -------------------------------------------------------------------------------- /Emulsion.TestFramework/Logging.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.TestFramework.Logging 6 | 7 | open Serilog 8 | open Xunit.Abstractions 9 | 10 | let xunitLogger (output: ITestOutputHelper): ILogger = 11 | LoggerConfiguration().MinimumLevel.Debug().WriteTo.TestOutput(output).CreateLogger() 12 | -------------------------------------------------------------------------------- /Emulsion.TestFramework/Signals.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.TestFramework.Signals 6 | 7 | open System 8 | open System.Threading.Tasks 9 | open JetBrains.Collections.Viewable 10 | open JetBrains.Lifetimes 11 | 12 | let WaitWithTimeout (lt: Lifetime) (source: ISource) (timeout: TimeSpan) (message: string): Task = task { 13 | let delay = Task.Delay timeout 14 | let waiter = source.NextValueAsync lt 15 | let! _ = Task.WhenAny(waiter, delay) 16 | if not waiter.IsCompleted then 17 | failwithf $"Timeout of {timeout} when waiting for {message}." 18 | do! Task.Yield() // to untangle further actions from the signal task termination 19 | } 20 | -------------------------------------------------------------------------------- /Emulsion.TestFramework/StreamUtils.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.TestFramework.StreamUtils 6 | 7 | open System.IO 8 | open Serilog 9 | 10 | let readAllBytes (logger: ILogger) (id: string) (stream: Stream) = async { 11 | use buffer = new MemoryStream() 12 | let! ct = Async.CancellationToken 13 | logger.Information("Reading stream {Id}…", id) 14 | do! Async.AwaitTask(stream.CopyToAsync(buffer, ct)) 15 | logger.Information("Successfully read stream {Id}.", id) 16 | return buffer.ToArray() 17 | } 18 | -------------------------------------------------------------------------------- /Emulsion.TestFramework/TelegramClientMock.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.TestFramework 6 | 7 | open System.Collections.Generic 8 | 9 | open Emulsion.Telegram 10 | 11 | type TelegramClientMock() = 12 | let responses = Dictionary() 13 | 14 | interface ITelegramClient with 15 | member this.GetFileInfo fileId = async.Return responses[fileId] 16 | 17 | member _.SetResponse(fileId: string, fileInfo: FileInfo option): unit = 18 | responses[fileId] <- fileInfo 19 | -------------------------------------------------------------------------------- /Emulsion.TestFramework/TestDataStorage.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.TestFramework.TestDataStorage 6 | 7 | open System.IO 8 | 9 | open Emulsion.Database 10 | 11 | let doWithDatabase<'a>(action: DatabaseSettings -> Async<'a>): Async<'a> = async { 12 | let databasePath = Path.GetTempFileName() 13 | let settings = { DataSource = databasePath } 14 | 15 | do! async { 16 | use context = new EmulsionDbContext(settings.ContextOptions) 17 | return! DataStorage.initializeDatabase context 18 | } 19 | 20 | return! action settings 21 | } 22 | -------------------------------------------------------------------------------- /Emulsion.TestFramework/Waiter.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.TestFramework.Waiter 6 | 7 | open System 8 | open System.Threading 9 | 10 | let defaultTimeout = TimeSpan.FromSeconds 30.0 11 | let shortTimeout = TimeSpan.FromSeconds 1.0 12 | 13 | let waitForItemCountCond (buffer: LockedBuffer<_>) (condition: int -> bool) (timeout: TimeSpan): bool = 14 | SpinWait.SpinUntil((fun () -> condition(buffer.Count())), timeout) 15 | 16 | let waitForItemCount (buffer: LockedBuffer<_>) count (timeout: TimeSpan): bool = 17 | waitForItemCountCond buffer (fun c -> c = count) timeout 18 | -------------------------------------------------------------------------------- /Emulsion.TestFramework/WebFileStorage.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.TestFramework 6 | 7 | open System 8 | open System.Net 9 | open System.Net.Sockets 10 | 11 | open System.Threading.Tasks 12 | open Microsoft.AspNetCore.Builder 13 | open Microsoft.AspNetCore.Http 14 | open Serilog 15 | 16 | module private NetUtil = 17 | let findFreePort() = 18 | use socket = new Socket(SocketType.Stream, ProtocolType.Tcp) 19 | socket.Bind(IPEndPoint(IPAddress.Loopback, 0)) 20 | (socket.LocalEndPoint :?> IPEndPoint).Port 21 | 22 | type WebFileStorage(logger: ILogger, data: Map) = 23 | let url = $"http://localhost:{NetUtil.findFreePort()}" 24 | 25 | let startWebApplication() = 26 | let builder = WebApplication.CreateBuilder() 27 | let app = builder.Build() 28 | app.MapGet("/{entry}", Func<_, _>(fun (entry: string) -> task { 29 | match Map.tryFind entry data with 30 | | Some bytes -> return Results.Bytes bytes 31 | | None -> return Results.NotFound() 32 | })) |> ignore 33 | app, app.RunAsync url 34 | 35 | let app, runTask = startWebApplication() 36 | 37 | member _.Link(entry: string): Uri = 38 | Uri $"{url}/{entry}" 39 | 40 | member _.Content(entry: string): byte[] = 41 | data[entry] 42 | 43 | interface IAsyncDisposable with 44 | member _.DisposeAsync(): ValueTask = ValueTask <| task { 45 | logger.Information "Stopping the test web server…" 46 | do! app.StopAsync() 47 | logger.Information "Stopped the test web server, waiting for app.RunAsync() to finish…" 48 | do! runTask 49 | logger.Information "Stopped the test web server completely." 50 | } 51 | -------------------------------------------------------------------------------- /Emulsion.Tests/ContentProxy/ContentStorageTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.ContentProxy.ContentStorageTests 6 | 7 | open Xunit 8 | 9 | open Emulsion.ContentProxy.ContentStorage 10 | open Emulsion.Database 11 | open Emulsion.TestFramework 12 | 13 | let private testIdentity = { 14 | ChatId = 0L 15 | ChatUserName = "test" 16 | MessageId = 123L 17 | FileId = "this_is_file" 18 | FileName = "file.bin" 19 | MimeType = "application/octet-stream" 20 | } 21 | 22 | let private executeQuery settings = 23 | DataStorage.transaction settings (fun context -> 24 | getOrCreateMessageRecord context testIdentity 25 | ) 26 | 27 | [] 28 | let ``getOrCreateMessageRecord returns an nonzero id``(): unit = 29 | TestDataStorage.doWithDatabase(fun settings -> async { 30 | let! newItem = executeQuery settings 31 | Assert.NotEqual(0L, newItem.Id) 32 | }) |> Async.RunSynchronously 33 | 34 | 35 | [] 36 | let ``getOrCreateMessageRecord returns a new record``(): unit = 37 | TestDataStorage.doWithDatabase(fun settings -> async { 38 | let! item = executeQuery settings 39 | Assert.Equal(testIdentity.ChatUserName, item.ChatUserName) 40 | Assert.Equal(testIdentity.MessageId, item.MessageId) 41 | Assert.Equal(testIdentity.FileId, item.FileId) 42 | }) |> Async.RunSynchronously 43 | 44 | [] 45 | let ``getOrCreateMessageRecord returns an existing record``(): unit = 46 | TestDataStorage.doWithDatabase(fun settings -> async { 47 | let! existingItem = executeQuery settings 48 | let! newItem = executeQuery settings 49 | Assert.Equal(existingItem, newItem) 50 | }) |> Async.RunSynchronously 51 | -------------------------------------------------------------------------------- /Emulsion.Tests/ContentProxy/ProxyTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.ContentProxy.ProxyTests 6 | 7 | open System 8 | 9 | open Xunit 10 | 11 | open Emulsion.ContentProxy 12 | 13 | let private salt = "mySalt" 14 | 15 | let private doTest number = 16 | let encoded = Proxy.encodeHashId salt number 17 | let decoded = Proxy.decodeHashId salt encoded 18 | 19 | Assert.Equal(number, decoded) 20 | 21 | [] 22 | let ``decode + encode should round-trip correctly``(): unit = doTest 123L 23 | 24 | [] 25 | let ``zero number round-trip``(): unit = doTest 0L 26 | 27 | [] 28 | let ``long number round-trip``(): unit = doTest 21474836470L 29 | 30 | [] 31 | let ``Int64.MaxValue round-trip``(): unit = doTest Int64.MaxValue 32 | -------------------------------------------------------------------------------- /Emulsion.Tests/Database/DataStorageTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.Database.InitializerTests 6 | 7 | open System.IO 8 | 9 | open Xunit 10 | 11 | open Emulsion.Database 12 | 13 | [] 14 | let ``Database initialization``(): unit = 15 | async { 16 | let databasePath = Path.Combine(Path.GetTempPath(), "emulsion-test.db") 17 | let settings = { DataSource = databasePath } 18 | use context = new EmulsionDbContext(settings.ContextOptions) 19 | let! _ = Async.AwaitTask(context.Database.EnsureDeletedAsync()) 20 | do! DataStorage.initializeDatabase context 21 | } |> Async.RunSynchronously 22 | -------------------------------------------------------------------------------- /Emulsion.Tests/Database/DatabaseStructureTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.Database.DatabaseStructureTests 6 | 7 | open Microsoft.Data.Sqlite 8 | open Xunit 9 | 10 | open Emulsion.Database 11 | open Emulsion.Database.Entities 12 | open Emulsion.TestFramework 13 | 14 | [] 15 | let ``Unique constraint should hold``(): unit = 16 | Async.RunSynchronously <| TestDataStorage.doWithDatabase(fun settings -> async { 17 | let addNewContent(ctx: EmulsionDbContext) = 18 | let newContent = { 19 | Id = 0L 20 | ChatId = 0L 21 | ChatUserName = "testChat" 22 | MessageId = 666L 23 | FileId = "foobar" 24 | FileName = "file.bin" 25 | MimeType = "application/octet-stream" 26 | } 27 | async { 28 | do! DataStorage.addAsync ctx.TelegramContents newContent 29 | let! _ = Async.AwaitTask(ctx.SaveChangesAsync()) 30 | return newContent.Id 31 | } 32 | 33 | let! id = DataStorage.transaction settings addNewContent 34 | Assert.NotEqual(0L, id) 35 | 36 | let! ex = Async.AwaitTask(Assert.ThrowsAnyAsync(fun() -> 37 | Async.StartAsTask(DataStorage.transaction settings addNewContent) 38 | )) 39 | let sqlEx = Exceptions.unwrap ex 40 | Assert.Contains("UNIQUE constraint failed", sqlEx.Message) 41 | }) 42 | -------------------------------------------------------------------------------- /Emulsion.Tests/Emulsion.Tests.fsproj: -------------------------------------------------------------------------------- 1 | 6 | 7 | 8 | 9 | net9.0 10 | false 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | -------------------------------------------------------------------------------- /Emulsion.Tests/ExceptionUtilsTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.ExceptionUtilsTests 6 | 7 | open System 8 | 9 | open Emulsion 10 | open Xunit 11 | 12 | [] 13 | let ``reraise works in sync code``(): unit = 14 | let nestedStacktrace() = 15 | raise <| Exception("Foo") 16 | let thrown = 17 | try 18 | nestedStacktrace() 19 | null 20 | with 21 | | ex -> ex 22 | let rethrown = Assert.Throws(fun () -> ExceptionUtils.reraise thrown |> ignore) 23 | Assert.Contains("nestedStacktrace", rethrown.StackTrace) 24 | 25 | [] 26 | let ``reraise works in async code``(): unit = 27 | let nestedStacktrace() = 28 | raise <| Exception("Foo") 29 | 30 | let ex = Assert.Throws(fun () -> 31 | async { 32 | try 33 | nestedStacktrace() 34 | with 35 | | ex -> 36 | ExceptionUtils.reraise ex 37 | } |> Async.RunSynchronously 38 | ) 39 | Assert.Contains("nestedStacktrace", ex.StackTrace) 40 | -------------------------------------------------------------------------------- /Emulsion.Tests/LifetimesTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.LifetimesTests 6 | 7 | open JetBrains.Lifetimes 8 | 9 | open Xunit 10 | 11 | open Emulsion.Lifetimes 12 | 13 | [] 14 | let ``awaitTermination completes after the parent lifetime is terminated``(): unit = 15 | use ld = Lifetime.Define() 16 | let task = Async.StartAsTask <| awaitTermination ld.Lifetime 17 | Assert.False task.IsCompleted 18 | ld.Terminate() 19 | task.GetAwaiter().GetResult() |> ignore 20 | -------------------------------------------------------------------------------- /Emulsion.Tests/LoggingTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.LoggingTests 6 | 7 | open Emulsion 8 | open JetBrains.Diagnostics 9 | open Serilog 10 | open Serilog.Core 11 | open Serilog.Events 12 | open Xunit 13 | 14 | [] 15 | let ``attachToRdLogSystem should proxy the logged messages``(): unit = 16 | let events = ResizeArray() 17 | let serilogLogger = { 18 | new ILogger with 19 | override this.Write(logEvent) = 20 | if logEvent.Properties[Constants.SourceContextPropertyName].ToString() = "\"LoggingTests\"" then 21 | lock events (fun() -> events.Add logEvent) 22 | } 23 | let rdLogger = Log.GetLog "LoggingTests" 24 | use _ = Logging.attachToRdLogSystem serilogLogger 25 | rdLogger.Info "foo" 26 | let event = lock events (fun() -> Assert.Single events) 27 | Assert.Equal(LogEventLevel.Information, event.Level) 28 | Assert.Equal("foo", event.MessageTemplate.Text) 29 | Assert.Equal("\"LoggingTests\"", event.Properties[Constants.SourceContextPropertyName].ToString()) 30 | lock events (fun() -> 31 | events.Clear() 32 | 33 | rdLogger.Error("Test {0}", 1) 34 | let event = Assert.Single events 35 | Assert.Equal(LogEventLevel.Error, event.Level) 36 | Assert.Equal("Test 1", event.MessageTemplate.Text) 37 | ) 38 | -------------------------------------------------------------------------------- /Emulsion.Tests/MessageSenderTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Tests 6 | 7 | open System 8 | open System.Threading 9 | 10 | open Serilog 11 | open Serilog.Events 12 | open Serilog.Sinks.TestCorrelator 13 | open Xunit 14 | open Xunit.Abstractions 15 | 16 | open Emulsion.Messaging 17 | open Emulsion.Messaging.MessageSender 18 | open Emulsion.TestFramework 19 | open Emulsion.TestFramework.Waiter 20 | 21 | type MessageSenderTests(testOutput: ITestOutputHelper) = 22 | let testContext = { 23 | Send = fun _ -> async { return () } 24 | Logger = Logging.xunitLogger testOutput 25 | RestartCooldown = TimeSpan.Zero 26 | } 27 | 28 | let createSender ctx token = 29 | new MailboxProcessor<_>(receiver ctx, token) 30 | 31 | let createBufferedContext() = 32 | let buffer = LockedBuffer() 33 | let context = { 34 | testContext with 35 | Send = fun m -> async { 36 | buffer.Add m 37 | } 38 | } 39 | buffer, context 40 | 41 | [] 42 | member _.``Message sender sends the messages sequentially``(): unit = 43 | use cts = new CancellationTokenSource() 44 | let buffer, context = createBufferedContext() 45 | let sender = startActivity(context, cts.Token) 46 | setReadyToAcceptMessages sender true 47 | 48 | let messagesSent = [| 1..100 |] |> Array.map (fun i -> 49 | OutgoingMessage (Authored { 50 | author = "author" 51 | text = string i 52 | }) 53 | ) 54 | messagesSent |> Array.iter(send sender) 55 | 56 | waitForItemCount buffer messagesSent.Length defaultTimeout 57 | |> Assert.True 58 | 59 | Assert.Equal(messagesSent, buffer.All()) 60 | 61 | [] 62 | member _.``Message sender should be cancellable``(): unit = 63 | use cts = new CancellationTokenSource() 64 | using (TestCorrelator.CreateContext()) (fun _ -> 65 | let context = { 66 | testContext with 67 | Send = fun _ -> failwith "Should not be called" 68 | Logger = LoggerConfiguration().WriteTo.TestCorrelator().CreateLogger() 69 | } 70 | let sender = startActivity(context, cts.Token) 71 | cts.Cancel() 72 | 73 | let msg = OutgoingMessage (Authored { author = "author"; text = "xx" }) 74 | send sender msg 75 | 76 | let getErrors() = 77 | TestCorrelator.GetLogEventsFromCurrentContext() 78 | |> Seq.filter (fun event -> event.Level = LogEventLevel.Error) 79 | 80 | SpinWait.SpinUntil((fun () -> Seq.length(getErrors()) > 0), shortTimeout) |> ignore 81 | Assert.Empty(getErrors()) 82 | ) 83 | 84 | [] 85 | member _.``Message sender does nothing when the system is not ready to process the messages``(): unit = 86 | use cts = new CancellationTokenSource() 87 | let buffer, context = createBufferedContext() 88 | let sender = startActivity(context, cts.Token) 89 | let msg = OutgoingMessage (Authored { author = "author"; text = "xx" }) 90 | 91 | setReadyToAcceptMessages sender true 92 | send sender msg 93 | waitForItemCount buffer 1 defaultTimeout |> Assert.True 94 | 95 | setReadyToAcceptMessages sender false 96 | send sender msg 97 | waitForItemCount buffer 2 shortTimeout |> Assert.False 98 | 99 | [] 100 | member _.``Message sender should empty the queue before blocking on further messages``(): unit = 101 | use cts = new CancellationTokenSource() 102 | let buffer, context = createBufferedContext() 103 | let sender = startActivity(context, cts.Token) 104 | setReadyToAcceptMessages sender false 105 | send sender (OutgoingMessage (Authored { author = "author"; text = "1" })) 106 | send sender (OutgoingMessage (Authored { author = "author"; text = "2" })) 107 | setReadyToAcceptMessages sender true 108 | waitForItemCount buffer 2 defaultTimeout |> Assert.True 109 | 110 | [] 111 | member _.``Message sender should prioritize the SetReceiveStatus msg over flushing the queue``(): unit = 112 | use cts = new CancellationTokenSource() 113 | let buffer = LockedBuffer() 114 | let mutable sender = Unchecked.defaultof<_> 115 | let context = { 116 | testContext with 117 | Send = fun m -> async { 118 | // Let's send the setReadyToAcceptMessages immediately before sending any message 119 | setReadyToAcceptMessages sender false 120 | buffer.Add m 121 | } 122 | } 123 | sender <- startActivity(context, cts.Token) 124 | 125 | // This will send a message and block the second one: 126 | setReadyToAcceptMessages sender true 127 | send sender (OutgoingMessage (Authored { author = "author"; text = "1" })) 128 | waitForItemCount buffer 1 defaultTimeout |> Assert.True 129 | 130 | send sender (OutgoingMessage (Authored { author = "author"; text = "2" })) 131 | waitForItemCount buffer 2 shortTimeout |> Assert.False 132 | 133 | [] 134 | member _.``Message sender should process the queue first before sending any messages``(): unit = 135 | use cts = new CancellationTokenSource() 136 | let buffer, context = createBufferedContext() 137 | let sender = createSender context cts.Token 138 | 139 | // First, create the message queue: 140 | setReadyToAcceptMessages sender true 141 | send sender (OutgoingMessage (Authored { author = "author"; text = "1" })) 142 | send sender (OutgoingMessage (Authored { author = "author"; text = "2" })) 143 | send sender (OutgoingMessage (Authored { author = "author"; text = "3" })) 144 | setReadyToAcceptMessages sender false 145 | 146 | // Now start the processor and check that the full queue was processed before sending any messages: 147 | sender.Start() 148 | waitForItemCountCond buffer (fun c -> c > 0) shortTimeout |> Assert.False 149 | -------------------------------------------------------------------------------- /Emulsion.Tests/MessageSystemTests/MessageSystemBaseTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Tests.MessageSystemTests 6 | 7 | open System 8 | open System.Threading 9 | open System.Threading.Tasks 10 | 11 | open Xunit 12 | open Xunit.Abstractions 13 | 14 | open Emulsion.Messaging 15 | open Emulsion.Messaging.MessageSystem 16 | open Emulsion.TestFramework 17 | open Emulsion.TestFramework.Waiter 18 | 19 | type MessageSystemBaseTests(testLogger: ITestOutputHelper) = 20 | let logger = Logging.xunitLogger testLogger 21 | 22 | let msg = OutgoingMessage (Authored { author = "author"; text = "text" }) 23 | 24 | [] 25 | member _.``Message system should not send any messages before being started``(): unit = 26 | let context = { RestartCooldown = TimeSpan.Zero; Logger = logger } 27 | let buffer = LockedBuffer() 28 | use cts = new CancellationTokenSource() 29 | let mutable enteredRunLoop = false 30 | let tcs = TaskCompletionSource() 31 | let messageSystem : IMessageSystem = 32 | { new MessageSystemBase(context, cts.Token) with 33 | member _.RunUntilError _ = 34 | async { 35 | do! Async.AwaitTask tcs.Task 36 | return async { 37 | Volatile.Write(&enteredRunLoop, true) 38 | do! Async.Sleep Int32.MaxValue 39 | } 40 | } 41 | member _.Send m = async { 42 | buffer.Add m 43 | } 44 | } 45 | // Start the system but don't let it to start the internal loop yet: 46 | putMessage messageSystem msg 47 | 48 | // No messages sent: 49 | waitForItemCount buffer 1 shortTimeout |> Assert.False 50 | Assert.Equal(false, Volatile.Read &enteredRunLoop) 51 | 52 | let task = Async.StartAsTask(async { messageSystem.RunSynchronously ignore }, cancellationToken = cts.Token) 53 | 54 | // Still no messages sent (because the task hasn't really been started yet): 55 | waitForItemCount buffer 1 shortTimeout |> Assert.False 56 | Assert.Equal(false, Volatile.Read &enteredRunLoop) 57 | 58 | // Now allow the task to start: 59 | tcs.SetResult() 60 | 61 | // Now the system should have entered the run loop and the message should be sent: 62 | waitForItemCount buffer 1 defaultTimeout |> Assert.True 63 | SpinWait.SpinUntil((fun () -> Volatile.Read &enteredRunLoop), shortTimeout) |> Assert.True 64 | Assert.Equal(Seq.singleton msg, buffer.All()) 65 | 66 | // Terminate the system: 67 | cts.Cancel() 68 | Assert.Throws(fun() -> task.GetAwaiter().GetResult()) |> ignore 69 | 70 | [] 71 | member _.``Message system should send the messages after being started``() = 72 | let context = { RestartCooldown = TimeSpan.Zero; Logger = logger } 73 | let buffer = LockedBuffer() 74 | use cts = new CancellationTokenSource() 75 | let messageSystem = 76 | { new MessageSystemBase(context, cts.Token) with 77 | member _.RunUntilError _ = 78 | async { return Async.Sleep Int32.MaxValue } 79 | member _.Send m = async { 80 | buffer.Add m 81 | } 82 | } 83 | putMessage messageSystem msg 84 | 85 | let messageReceiver = ignore 86 | let runningSystem = Task.Run(fun () -> (messageSystem :> IMessageSystem).RunSynchronously messageReceiver) 87 | 88 | waitForItemCount buffer 1 defaultTimeout |> Assert.True 89 | Assert.Equal(Seq.singleton msg, buffer.All()) 90 | 91 | cts.Cancel() 92 | Assert.Throws(fun () -> runningSystem.GetAwaiter().GetResult()) 93 | 94 | -------------------------------------------------------------------------------- /Emulsion.Tests/MessageSystemTests/WrapRunTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.MessageSystemTests.WrapRunTests 6 | 7 | open System 8 | open System.Threading 9 | 10 | open Serilog.Core 11 | open Xunit 12 | 13 | open Emulsion.Messaging.MessageSystem 14 | 15 | let private performTest expectedStage runBody = 16 | use cts = new CancellationTokenSource() 17 | let mutable stage = 0 18 | let run = async { 19 | stage <- stage + 1 20 | runBody cts stage 21 | } 22 | let context = { 23 | RestartCooldown = TimeSpan.Zero 24 | Logger = Logger.None 25 | } 26 | 27 | try 28 | Async.RunSynchronously(wrapRun context run, cancellationToken = cts.Token) 29 | with 30 | | :? OperationCanceledException -> () 31 | 32 | Assert.Equal(expectedStage, stage) 33 | 34 | [] 35 | let ``wrapRun should restart the activity on error``() = 36 | performTest 2 (fun cts stage -> 37 | match stage with 38 | | 1 -> raise <| Exception() 39 | | 2 -> cts.Cancel() 40 | | _ -> failwith "Impossible" 41 | ) 42 | 43 | [] 44 | let ``wrapRun should not restart on OperationCanceledException``() = 45 | performTest 1 (fun cts _ -> 46 | cts.Cancel() 47 | cts.Token.ThrowIfCancellationRequested() 48 | ) 49 | 50 | [] 51 | let ``wrapRun should not restart on token.Cancel()``() = 52 | performTest 4 (fun cts stage -> 53 | if stage > 3 then 54 | cts.Cancel() 55 | ) 56 | -------------------------------------------------------------------------------- /Emulsion.Tests/MessagingCoreTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Tests 6 | 7 | open System 8 | open System.Threading 9 | open System.Threading.Channels 10 | open System.Threading.Tasks 11 | open Emulsion 12 | open Emulsion.Messaging 13 | open Emulsion.Messaging.MessageSystem 14 | open Emulsion.TestFramework 15 | open JetBrains.Lifetimes 16 | open Xunit 17 | open Xunit.Abstractions 18 | 19 | type MessagingCoreTests(output: ITestOutputHelper) = 20 | 21 | let logger = Logging.xunitLogger output 22 | let dummyMessageSystem = { 23 | new IMessageSystem with 24 | override this.PutMessage _ = () 25 | override this.RunSynchronously _ = () 26 | } 27 | 28 | let waitTimeout = TimeSpan.FromSeconds 10.0 29 | let waitSuccessfulProcessing lt (core: MessagingCore) = 30 | Signals.WaitWithTimeout lt core.MessageProcessedSuccessfully waitTimeout "message processed successfully" 31 | let waitProcessingError lt (core: MessagingCore) = 32 | Signals.WaitWithTimeout lt core.MessageProcessingError waitTimeout "message processed with error" 33 | 34 | let newMessageSystem (receivedMessages: Channel<_>) = { 35 | new IMessageSystem with 36 | override this.PutMessage m = 37 | let result = receivedMessages.Writer.TryWrite m 38 | Assert.True(result, "Channel should accept an incoming message") 39 | override this.RunSynchronously _ = () 40 | } 41 | 42 | let testMessage = Authored { 43 | author = "cthulhu" 44 | text = "fhtagn" 45 | } 46 | 47 | [] 48 | member _.``MessagingCore calls archive if it's present``(): Task = task { 49 | use ld = new LifetimeDefinition() 50 | let lt = ld.Lifetime 51 | let messages = Channel.CreateUnbounded() 52 | let archive = { 53 | new IMessageArchive with 54 | override this.Archive(message) = 55 | messages.Writer.WriteAsync(message).AsTask() 56 | |> Async.AwaitTask 57 | } 58 | 59 | let core = MessagingCore(lt, logger, Some archive) 60 | core.Start(dummyMessageSystem, dummyMessageSystem) 61 | 62 | let expected = IncomingMessage.TelegramMessage(testMessage) 63 | core.ReceiveMessage expected 64 | let! actual = messages.Reader.ReadAsync() 65 | 66 | Assert.Equal(expected, actual) 67 | } 68 | 69 | [] 70 | member _.``MessagingCore sends XMPP message to Telegram and vise-versa``(): Task = task { 71 | let telegramReceived = Channel.CreateUnbounded() 72 | let xmppReceived = Channel.CreateUnbounded() 73 | 74 | let xmpp = newMessageSystem xmppReceived 75 | let telegram = newMessageSystem telegramReceived 76 | 77 | use ld = new LifetimeDefinition(Id = "Test core lifetime") 78 | let lt = ld.Lifetime 79 | let core = MessagingCore(lt, logger, None) 80 | core.Start(telegram, xmpp) 81 | 82 | let sendMessageAndAssertReceival incomingMessage text (received: Channel<_>) = task { 83 | let message = Authored { 84 | author = "cthulhu" 85 | text = text 86 | } 87 | 88 | let incoming = incomingMessage message 89 | core.ReceiveMessage incoming 90 | let! outgoing = received.Reader.ReadAsync() 91 | Assert.Equal(OutgoingMessage message, outgoing) 92 | } 93 | 94 | do! sendMessageAndAssertReceival XmppMessage "text1" telegramReceived 95 | do! sendMessageAndAssertReceival TelegramMessage "text2" xmppReceived 96 | } 97 | 98 | [] 99 | member _.``MessagingCore buffers the message received before start``(): Task = task { 100 | let telegramReceived = Channel.CreateUnbounded() 101 | let telegram = newMessageSystem telegramReceived 102 | 103 | use ld = new LifetimeDefinition() 104 | let lt = ld.Lifetime 105 | let core = MessagingCore(lt, logger, None) 106 | 107 | core.ReceiveMessage(XmppMessage testMessage) 108 | let hasMessages, _ = telegramReceived.Reader.TryPeek() 109 | Assert.False(hasMessages, "No message is expected to be available.") 110 | 111 | core.Start(telegram, dummyMessageSystem) 112 | let! receivedMessage = telegramReceived.Reader.ReadAsync() 113 | Assert.Equal(OutgoingMessage testMessage, receivedMessage) 114 | } 115 | 116 | [] 117 | member _.``MessagingCore terminates its processing``(): Task = task { 118 | use ld = new LifetimeDefinition() 119 | let lt = ld.Lifetime 120 | let core = MessagingCore(lt, logger, None) 121 | 122 | let message = Authored { 123 | author = "cthulhu" 124 | text = "fhtagn" 125 | } 126 | for _ in 1..100 do 127 | core.ReceiveMessage(XmppMessage message) 128 | 129 | core.Start(dummyMessageSystem, dummyMessageSystem) 130 | ld.Terminate() 131 | 132 | Assert.True( 133 | SpinWait.SpinUntil((fun() -> core.ProcessingTask.Value.IsCompleted), TimeSpan.FromSeconds 1.0), 134 | "Task should be completed in time" 135 | ) 136 | } 137 | 138 | [] 139 | member _.``MessagingCore should log an error if receiving a message after termination``(): Task = task { 140 | use ld = new LifetimeDefinition() 141 | let lt = ld.Lifetime 142 | let core = MessagingCore(lt, logger, None) 143 | core.Start(dummyMessageSystem, dummyMessageSystem) 144 | ld.Terminate() 145 | 146 | Lifetime.Using(fun lt -> 147 | let mutable signaled = false 148 | core.MessageCannotBeReceived.Advise(lt, fun() -> signaled <- true) 149 | core.ReceiveMessage(TelegramMessage testMessage) 150 | Assert.True(signaled, "Error on message after termination should be reported.") 151 | ) 152 | } 153 | 154 | [] 155 | member _.``MessagingCore should log an error during processing``(): Task = task { 156 | use ld = new LifetimeDefinition() 157 | let lt = ld.Lifetime 158 | let core = MessagingCore(lt, logger, None) 159 | 160 | let mutable shouldThrow = true 161 | let received = ResizeArray() 162 | let throwingSystem = { 163 | new IMessageSystem with 164 | member this.PutMessage m = 165 | if Volatile.Read(&shouldThrow) 166 | then failwith "Error." 167 | else lock received (fun() -> received.Add m) 168 | member this.RunSynchronously _ = () 169 | } 170 | 171 | core.Start(telegram = throwingSystem, xmpp = dummyMessageSystem) 172 | let awaitMessage = waitSuccessfulProcessing lt core 173 | 174 | let awaitError = waitProcessingError lt core 175 | core.ReceiveMessage(XmppMessage testMessage) 176 | do! awaitError // error signalled correctly 177 | 178 | Volatile.Write(&shouldThrow, false) 179 | do! Lifetime.UsingAsync(fun lt -> task { 180 | let mutable signaled = false 181 | core.MessageProcessingError.Advise(lt, fun() -> Volatile.Write(&signaled, true)) 182 | core.ReceiveMessage(XmppMessage testMessage) 183 | do! awaitMessage 184 | Assert.False(Volatile.Read(&signaled), "There should be no error.") 185 | }) 186 | } 187 | -------------------------------------------------------------------------------- /Emulsion.Tests/SettingsTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.SettingsTests 6 | 7 | open System 8 | open System.IO 9 | open System.Threading.Tasks 10 | 11 | open Microsoft.Extensions.Configuration 12 | open Xunit 13 | 14 | open Emulsion.Settings 15 | 16 | let private testConfigText groupIdLiteral extendedLiteral = 17 | sprintf @"{ 18 | ""xmpp"": { 19 | ""login"": ""login"", 20 | ""password"": ""password"", 21 | ""room"": ""room"", 22 | ""nickname"": ""nickname"", 23 | ""messageTimeout"": ""00:00:30"", 24 | ""pingTimeout"": ""00:00:30"" 25 | }, 26 | ""telegram"": { 27 | ""token"": ""token"", 28 | ""groupId"": %s 29 | }, 30 | ""log"": { 31 | ""directory"": ""/tmp/"" 32 | }%s 33 | }" <| groupIdLiteral <| extendedLiteral 34 | 35 | let private testGroupId = 200600L 36 | let private testConfiguration = { 37 | Xmpp = { 38 | Login = "login" 39 | Password = "password" 40 | Room = "room" 41 | RoomPassword = None 42 | Nickname = "nickname" 43 | ConnectionTimeout = TimeSpan.FromMinutes 5.0 44 | MessageTimeout = TimeSpan.FromSeconds 30.0 45 | PingInterval = None 46 | PingTimeout = TimeSpan.FromSeconds 30.0 47 | } 48 | Telegram = { 49 | Token = "token" 50 | GroupId = testGroupId 51 | MessageThreadId = None 52 | } 53 | Log = { 54 | Directory = "/tmp/" 55 | } 56 | MessageArchive = { 57 | IsEnabled = false 58 | } 59 | Database = None 60 | Hosting = None 61 | FileCache = None 62 | } 63 | 64 | let private mockConfiguration groupIdLiteral extendedJson = 65 | let path = Path.GetTempFileName() 66 | task { 67 | do! File.WriteAllTextAsync(path, testConfigText groupIdLiteral extendedJson) 68 | return ConfigurationBuilder().AddJsonFile(path).Build() 69 | } 70 | 71 | 72 | [] 73 | let ``Settings read properly`` () = 74 | task { 75 | let! configuration = mockConfiguration (string testGroupId) "" 76 | Assert.Equal(testConfiguration, read configuration) 77 | } 78 | 79 | [] 80 | let ``Settings read the group id as string``(): Task = 81 | task { 82 | let! configuration = mockConfiguration "\"200600\"" "" 83 | Assert.Equal(testConfiguration, read configuration) 84 | } 85 | 86 | [] 87 | let ``Extended settings read properly``(): Task = task { 88 | let! configuration = mockConfiguration (string testGroupId) @", 89 | ""database"": { 90 | ""dataSource"": "":memory:"" 91 | }, 92 | ""hosting"": { 93 | ""externalUriBase"": ""https://example.com"", 94 | ""bindUri"": ""http://localhost:5555"", 95 | ""hashIdSalt"": ""123123123"" 96 | }" 97 | let expectedConfiguration = 98 | { testConfiguration with 99 | Database = Some { 100 | DataSource = ":memory:" 101 | } 102 | Hosting = Some { 103 | ExternalUriBase = Uri "https://example.com" 104 | BindUri = "http://localhost:5555" 105 | HashIdSalt = "123123123" 106 | } 107 | } 108 | Assert.Equal(expectedConfiguration, read configuration) 109 | } 110 | -------------------------------------------------------------------------------- /Emulsion.Tests/Telegram/Html.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.Telegram.Html 6 | 7 | open Xunit 8 | 9 | open Emulsion.Telegram 10 | 11 | [] 12 | let ``Html should escape properly``() = 13 | Assert.Equal("<html>&<css>", Html.escape "&") 14 | Assert.Equal("<script>alert('XSS')</script>", Html.escape "") 15 | Assert.Equal("noescape", Html.escape "noescape") 16 | -------------------------------------------------------------------------------- /Emulsion.Tests/Telegram/LinkGeneratorTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.Telegram.LinkGeneratorTests 6 | 7 | open System 8 | 9 | open Funogram.Telegram.Types 10 | open Serilog.Core 11 | open Xunit 12 | 13 | open Emulsion.ContentProxy 14 | open Emulsion.Database 15 | open Emulsion.Settings 16 | open Emulsion.Telegram 17 | open Emulsion.TestFramework 18 | 19 | let private hostingSettings = { 20 | ExternalUriBase = Uri "https://example.com" 21 | BindUri = "http://localhost:5556" 22 | HashIdSalt = "mySalt" 23 | } 24 | let private chatName = "test_chat" 25 | let private fileId1 = "123456" 26 | let private fileId2 = "654321" 27 | 28 | let private photo: PhotoSize = 29 | { 30 | FileId = fileId1 31 | FileUniqueId = fileId1 32 | Width = 0 33 | Height = 0 34 | FileSize = None 35 | } 36 | 37 | let private messageTemplate = 38 | Message.Create( 39 | messageId = 0L, 40 | date = DateTime.MinValue, 41 | chat = Chat.Create( 42 | id = 0L, 43 | ``type`` = ChatType.SuperGroup, 44 | username = chatName 45 | ) 46 | ) 47 | 48 | let private messageWithDocument = 49 | { messageTemplate with 50 | Document = Some { 51 | FileId = fileId1 52 | FileUniqueId = fileId1 53 | Thumbnail = None 54 | FileName = None 55 | MimeType = None 56 | FileSize = None 57 | } 58 | } 59 | 60 | let private messageWithAudio = 61 | { messageTemplate with 62 | Audio = Some { 63 | FileId = fileId1 64 | FileUniqueId = fileId1 65 | FileName = None 66 | Duration = 0 67 | Performer = None 68 | Title = None 69 | MimeType = None 70 | FileSize = None 71 | Thumbnail = None 72 | } 73 | } 74 | 75 | let private messageWithAnimation = 76 | { messageTemplate with 77 | Animation = Some <| Animation.Create( 78 | fileId = fileId1, 79 | fileUniqueId = fileId1, 80 | width = 0L, 81 | height = 0L, 82 | duration = 0L 83 | ) 84 | } 85 | 86 | let private messageWithPhoto = 87 | { messageTemplate with 88 | Photo = Some([| photo |]) 89 | } 90 | 91 | let private messageWithMultiplePhotos = 92 | { messageWithPhoto with 93 | Photo = Some(Array.append (Option.get messageWithPhoto.Photo) [|{ 94 | FileId = fileId2 95 | FileUniqueId = fileId2 96 | Width = 1000 97 | Height = 2000 98 | FileSize = None 99 | }|]) 100 | } 101 | 102 | let private messageWithSticker = 103 | { messageTemplate with 104 | Sticker = Some <| Sticker.Create( 105 | fileId = fileId1, 106 | fileUniqueId = fileId1, 107 | ``type`` = "", 108 | width = 0, 109 | height = 0, 110 | isAnimated = false, 111 | isVideo = false 112 | ) 113 | } 114 | 115 | let private messageWithVideoSticker = 116 | { messageTemplate with 117 | Sticker = Some <| Sticker.Create( 118 | fileId = fileId1, 119 | fileUniqueId = fileId1, 120 | ``type`` = "", 121 | width = 0, 122 | height = 0, 123 | isAnimated = false, 124 | isVideo = true 125 | ) 126 | } 127 | 128 | let private messageWithAnimatedSticker = 129 | { messageTemplate with 130 | Sticker = Some <| Sticker.Create( 131 | fileId = fileId2, 132 | fileUniqueId = fileId2, 133 | ``type`` = "", 134 | width = 0, 135 | height = 0, 136 | isAnimated = true, 137 | isVideo = false, 138 | thumbnail = photo 139 | ) 140 | } 141 | 142 | let private messageWithVideo = 143 | { messageTemplate with 144 | Video = Some { 145 | FileId = fileId1 146 | FileUniqueId = fileId1 147 | FileName = None 148 | Width = 0 149 | Height = 0 150 | Duration = 0 151 | Thumbnail = None 152 | MimeType = None 153 | FileSize = None 154 | } 155 | } 156 | 157 | let private messageWithVoice = 158 | { messageTemplate with 159 | Voice = Some { 160 | FileId = fileId1 161 | FileUniqueId = fileId1 162 | Duration = 0 163 | MimeType = None 164 | FileSize = None 165 | } 166 | } 167 | 168 | let private messageWithVideoNote = 169 | { messageTemplate with 170 | VideoNote = Some { 171 | FileId = fileId1 172 | FileUniqueId = fileId1 173 | Length = 0 174 | Duration = 0 175 | Thumbnail = None 176 | FileSize = None 177 | } 178 | } 179 | 180 | let private doBasicLinkTest message = 181 | let links = Async.RunSynchronously(LinkGenerator.gatherLinks Logger.None None None message) 182 | let expectedUri = Seq.singleton <| Uri $"https://t.me/{chatName}/{message.MessageId}" 183 | Assert.Equal(expectedUri, links.ContentLinks) 184 | 185 | let private doDatabaseLinksTest (fileIds: string[]) message = 186 | Async.RunSynchronously <| TestDataStorage.doWithDatabase(fun databaseSettings -> 187 | async { 188 | let! links = LinkGenerator.gatherLinks Logger.None (Some databaseSettings) (Some hostingSettings) message 189 | let contentLinks = Seq.toArray links.ContentLinks 190 | for fileId, link in Seq.zip fileIds contentLinks do 191 | let link = link.ToString() 192 | let baseUri = hostingSettings.ExternalUriBase.ToString() 193 | Assert.StartsWith(baseUri, link) 194 | let emptyLinkLength = (Proxy.getLink hostingSettings.ExternalUriBase "").ToString().Length 195 | let id = link.Substring(emptyLinkLength) 196 | let! content = DataStorage.transaction databaseSettings (fun context -> 197 | ContentStorage.getById context (Proxy.decodeHashId hostingSettings.HashIdSalt id) 198 | ) 199 | let content = Option.get content 200 | 201 | Assert.Equal(message.MessageId, content.MessageId) 202 | Assert.Equal(message.Chat.Username, Some content.ChatUserName) 203 | Assert.Equal(fileId, content.FileId) 204 | 205 | Assert.Equal(fileIds.Length, contentLinks.Length) 206 | } 207 | ) 208 | 209 | let private doDatabaseLinkTest fileId message = 210 | doDatabaseLinksTest [|fileId|] message 211 | 212 | [] 213 | let documentLinkTest(): unit = doBasicLinkTest messageWithDocument 214 | 215 | [] 216 | let databaseDocumentTest(): unit = doDatabaseLinkTest fileId1 messageWithDocument 217 | 218 | [] 219 | let databaseAudioTest(): unit = doDatabaseLinkTest fileId1 messageWithAudio 220 | 221 | [] 222 | let databaseAnimationTest(): unit = doDatabaseLinkTest fileId1 messageWithAnimation 223 | 224 | [] 225 | let databasePhotoTest(): unit = doDatabaseLinkTest fileId1 messageWithPhoto 226 | 227 | [] 228 | let databaseStickerTest(): unit = doDatabaseLinkTest fileId1 messageWithSticker 229 | 230 | [] 231 | let databaseVideoStickerTest(): unit = doDatabaseLinkTest fileId1 messageWithVideoSticker 232 | 233 | [] 234 | let databaseAnimatedStickerTest(): unit = doDatabaseLinkTest fileId1 messageWithAnimatedSticker 235 | 236 | [] 237 | let databaseVideoTest(): unit = doDatabaseLinkTest fileId1 messageWithVideo 238 | 239 | [] 240 | let databaseVoiceTest(): unit = doDatabaseLinkTest fileId1 messageWithVoice 241 | 242 | [] 243 | let databaseVideoNoteTest(): unit = doDatabaseLinkTest fileId1 messageWithVideoNote 244 | 245 | [] 246 | let databaseMultiplePhotosTest(): unit = doDatabaseLinksTest [|fileId2|] messageWithMultiplePhotos 247 | -------------------------------------------------------------------------------- /Emulsion.Tests/Web/ContentControllerTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Tests.Web 6 | 7 | open System 8 | open System.Security.Cryptography 9 | open System.Threading.Tasks 10 | 11 | open Microsoft.AspNetCore.Mvc 12 | open Microsoft.Extensions.Logging 13 | open Serilog.Extensions.Logging 14 | open Xunit 15 | open Xunit.Abstractions 16 | 17 | open Emulsion.ContentProxy 18 | open Emulsion.Database 19 | open Emulsion.Database.Entities 20 | open Emulsion.Settings 21 | open Emulsion.Telegram 22 | open Emulsion.TestFramework 23 | open Emulsion.TestFramework.Logging 24 | open Emulsion.Web 25 | 26 | type ContentControllerTests(output: ITestOutputHelper) = 27 | 28 | let hostingSettings = { 29 | ExternalUriBase = Uri "https://example.com/emulsion" 30 | BindUri = "http://localhost:5557" 31 | HashIdSalt = "test_salt" 32 | } 33 | 34 | let logger = xunitLogger output 35 | let telegramClient = TelegramClientMock() 36 | let sha256 = SHA256.Create() 37 | 38 | let cacheDirectory = lazy FileCacheUtil.newCacheDirectory() 39 | 40 | let setUpFileCache() = 41 | FileCacheUtil.setUpFileCache output sha256 cacheDirectory.Value 0UL 42 | 43 | let performTestWithPreparation fileCache prepareAction testAction = Async.StartAsTask(async { 44 | return! TestDataStorage.doWithDatabase(fun databaseSettings -> async { 45 | do! prepareAction databaseSettings 46 | 47 | use loggerFactory = new SerilogLoggerFactory(logger) 48 | let logger = loggerFactory.CreateLogger() 49 | use context = new EmulsionDbContext(databaseSettings.ContextOptions) 50 | let controller = ContentController(logger, hostingSettings, telegramClient, (fun () -> fileCache), context) 51 | return! testAction controller 52 | }) 53 | }) 54 | 55 | let performTest = performTestWithPreparation None (fun _ -> async.Return()) 56 | let performTestWithContent fileCache content = performTestWithPreparation fileCache (fun databaseOptions -> async { 57 | use context = new EmulsionDbContext(databaseOptions.ContextOptions) 58 | do! DataStorage.addAsync context.TelegramContents content 59 | return! Async.Ignore <| Async.AwaitTask(context.SaveChangesAsync()) 60 | }) 61 | 62 | interface IDisposable with 63 | member _.Dispose() = sha256.Dispose() 64 | 65 | [] 66 | member _.``ContentController returns BadRequest on hashId deserialization error``(): Task = 67 | performTest (fun controller -> async { 68 | let hashId = "z-z-z-z-z" 69 | let! result = Async.AwaitTask <| controller.Get hashId 70 | Assert.IsType result |> ignore 71 | }) 72 | 73 | [] 74 | member _.``ContentController returns NotFound if the content doesn't exist in the database``(): Task = 75 | performTest (fun controller -> async { 76 | let hashId = Proxy.encodeHashId hostingSettings.HashIdSalt 667L 77 | let! result = Async.AwaitTask <| controller.Get hashId 78 | Assert.IsType result |> ignore 79 | }) 80 | 81 | [] 82 | member _.``ContentController returns a normal redirect if there's no file cache``(): Task = 83 | let contentId = 343L 84 | let chatUserName = "MySuperExampleChat" 85 | let messageId = 777L 86 | let content = { 87 | Id = contentId 88 | ChatId = 0L 89 | ChatUserName = chatUserName 90 | MessageId = messageId 91 | FileId = "foobar" 92 | FileName = "file.bin" 93 | MimeType = "application/octet-stream" 94 | } 95 | 96 | performTestWithContent None content (fun controller -> async { 97 | let hashId = Proxy.encodeHashId hostingSettings.HashIdSalt contentId 98 | let! result = Async.AwaitTask <| controller.Get hashId 99 | let redirect = Assert.IsType result 100 | Assert.Equal(Uri $"https://t.me/{chatUserName}/{string messageId}", Uri redirect.Url) 101 | }) 102 | 103 | [] 104 | member _.``ContentController returns NotFound if the content doesn't exist on the Telegram server``(): Task = task { 105 | let contentId = 344L 106 | let chatUserName = "MySuperExampleChat" 107 | let messageId = 777L 108 | let fileId = "foobar1" 109 | let content = { 110 | Id = contentId 111 | ChatId = 0L 112 | ChatUserName = chatUserName 113 | MessageId = messageId 114 | FileId = fileId 115 | FileName = "file.bin" 116 | MimeType = "application/octet-stream" 117 | } 118 | 119 | telegramClient.SetResponse(fileId, None) 120 | 121 | use fileCache = setUpFileCache() 122 | do! performTestWithContent (Some fileCache) content (fun controller -> async { 123 | let hashId = Proxy.encodeHashId hostingSettings.HashIdSalt contentId 124 | let! result = Async.AwaitTask <| controller.Get hashId 125 | Assert.IsType result |> ignore 126 | }) 127 | } 128 | 129 | [] 130 | member _.``ContentController returns 404 if the cache reports that a file was not found``(): Task = task { 131 | let contentId = 344L 132 | let chatUserName = "MySuperExampleChat" 133 | let messageId = 777L 134 | let fileId = "foobar1" 135 | let content = { 136 | Id = contentId 137 | ChatId = 0L 138 | ChatUserName = chatUserName 139 | MessageId = messageId 140 | FileId = fileId 141 | FileName = "file.bin" 142 | MimeType = "application/octet-stream" 143 | } 144 | 145 | use fileCache = setUpFileCache() 146 | use fileStorage = new WebFileStorage(logger, Map.empty) 147 | telegramClient.SetResponse(fileId, Some { 148 | TemporaryLink = fileStorage.Link fileId 149 | Size = 1UL 150 | }) 151 | 152 | do! performTestWithContent (Some fileCache) content (fun controller -> async { 153 | let hashId = Proxy.encodeHashId hostingSettings.HashIdSalt contentId 154 | let! result = Async.AwaitTask <| controller.Get hashId 155 | Assert.IsType result |> ignore 156 | }) 157 | } 158 | 159 | [] 160 | member _.``ContentController returns a downloaded file from cache``(): Task = task { 161 | let contentId = 343L 162 | let chatUserName = "MySuperExampleChat" 163 | let messageId = 777L 164 | let fileId = "foobar" 165 | let content = { 166 | Id = contentId 167 | ChatId = 0L 168 | ChatUserName = chatUserName 169 | MessageId = messageId 170 | FileId = fileId 171 | FileName = "file.bin" 172 | MimeType = "application/octet-stream" 173 | } 174 | 175 | let onServerFileId = "fileIdOnServer" 176 | use fileCache = setUpFileCache() 177 | use fileStorage = new WebFileStorage(logger, Map.ofArray [| onServerFileId, [| 1uy; 2uy; 3uy |] |]) 178 | let testFileInfo = { 179 | TemporaryLink = fileStorage.Link onServerFileId 180 | Size = 1UL 181 | } 182 | telegramClient.SetResponse(fileId, Some testFileInfo) 183 | 184 | do! performTestWithContent (Some fileCache) content (fun controller -> async { 185 | let hashId = Proxy.encodeHashId hostingSettings.HashIdSalt contentId 186 | let! result = Async.AwaitTask <| controller.Get hashId 187 | let streamResult = Assert.IsType result 188 | let! content = StreamUtils.readAllBytes logger "fileIdOnServer" streamResult.FileStream 189 | Assert.Equal(fileStorage.Content onServerFileId, content) 190 | }) 191 | } 192 | -------------------------------------------------------------------------------- /Emulsion.Tests/Xmpp/SharpXmppHelperTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2025 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.Xmpp.SharpXmppHelperTests 6 | 7 | open System.Xml.Linq 8 | 9 | open SharpXMPP.XMPP 10 | open SharpXMPP.XMPP.Client.Elements 11 | open Xunit 12 | 13 | open Emulsion.Messaging 14 | open Emulsion.Tests.Xmpp 15 | open Emulsion.Xmpp 16 | open Emulsion.Xmpp.SharpXmppHelper.Attributes 17 | open Emulsion.Xmpp.SharpXmppHelper.Elements 18 | 19 | [] 20 | let ``SanitizeXmlText processes emoji as-is``(): unit = 21 | Assert.Equal("🐙", SharpXmppHelper.SanitizeXmlText "🐙") 22 | Assert.Equal("test🐙", SharpXmppHelper.SanitizeXmlText "test🐙") 23 | 24 | [] 25 | let ``SanitizeXmlText replaces parts of UTF-16 surrogate pair with the replacement char``(): unit = 26 | let octopus = "🐙" 27 | Assert.Equal(2, octopus.Length) 28 | let firstHalf = string(octopus[0]) 29 | let secondHalf = string(octopus[1]) 30 | Assert.Equal("🐙", firstHalf + secondHalf) 31 | Assert.Equal("�", SharpXmppHelper.SanitizeXmlText firstHalf) 32 | Assert.Equal("�", SharpXmppHelper.SanitizeXmlText secondHalf) 33 | Assert.Equal("test�", SharpXmppHelper.SanitizeXmlText $"test{secondHalf}") 34 | 35 | [] 36 | let ``Message body has a proper namespace``() = 37 | let message = SharpXmppHelper.message "" "cthulhu@test" "text" 38 | let body = Seq.exactlyOne(message.Descendants()) 39 | Assert.Equal(XNamespace.Get "jabber:client", body.Name.Namespace) 40 | 41 | [] 42 | let ``parseMessage should extract message text and author``() = 43 | let text = "text test" 44 | let element = XmppMessageFactory.create("x@y/author", text) 45 | let message = SharpXmppHelper.parseMessage element 46 | let expected = Authored { author = "author"; text = text } 47 | Assert.Equal(expected, message) 48 | 49 | [] 50 | let ``Message without author is attributed to [UNKNOWN USER]``() = 51 | let text = "xxx" 52 | let element = XmppMessageFactory.create(text = text) 53 | let message = SharpXmppHelper.parseMessage element 54 | let expected = Authored { author = "[UNKNOWN USER]"; text = text } 55 | Assert.Equal(expected, message) 56 | 57 | [] 58 | let ``isOwnMessage detects own message by resource``() = 59 | let message = XmppMessageFactory.create("a@b/myNickname", "text") 60 | Assert.True(SharpXmppHelper.isOwnMessage "myNickname" message) 61 | 62 | [] 63 | let ``isOwnMessage detects foreign message``() = 64 | let message = XmppMessageFactory.create("a@b/notMyNickname", "text") 65 | Assert.False(SharpXmppHelper.isOwnMessage "myNickname" message) 66 | 67 | [] 68 | let ``isOwnMessage detects nobody's message``() = 69 | let message = XmppMessageFactory.create() 70 | Assert.False(SharpXmppHelper.isOwnMessage "myNickname" message) 71 | 72 | [] 73 | let ``isHistoricalMessage returns false for an ordinary message``() = 74 | let message = XmppMessageFactory.create() 75 | Assert.False(SharpXmppHelper.isHistoricalMessage message) 76 | 77 | [] 78 | let ``isHistoricalMessage returns true for a message with delay``() = 79 | let message = XmppMessageFactory.create(delayDate = "2010-01-01") 80 | Assert.True(SharpXmppHelper.isHistoricalMessage message) 81 | 82 | [] 83 | let ``Message without body is considered as empty``(): unit = 84 | let message = XmppMessageFactory.create() 85 | Assert.True(SharpXmppHelper.isEmptyMessage message) 86 | 87 | [] 88 | let ``Message consisting of whitespace is considered as empty``(): unit = 89 | let message = XmppMessageFactory.create(text = " \t ") 90 | Assert.True(SharpXmppHelper.isEmptyMessage message) 91 | 92 | [] 93 | let ``Message with text is not considered as empty``(): unit = 94 | let message = XmppMessageFactory.create(text = " t ") 95 | Assert.False(SharpXmppHelper.isEmptyMessage message) 96 | 97 | [] 98 | let ``Message with proper type is a group chat message``(): unit = 99 | Assert.True(SharpXmppHelper.isGroupChatMessage(XmppMessageFactory.create(messageType = "groupchat"))) 100 | Assert.False(SharpXmppHelper.isGroupChatMessage(XmppMessageFactory.create(messageType = "error"))) 101 | 102 | [] 103 | let ``isPing determines ping IQ query according to the spec``(): unit = 104 | let jid = JID("room@conference.example.com/me") 105 | let ping = SharpXmppHelper.ping jid "myTest" 106 | Assert.True(SharpXmppHelper.isPing ping) 107 | 108 | ping.Element(Ping).Remove() 109 | Assert.False(SharpXmppHelper.isPing ping) 110 | 111 | [] 112 | let ``isPong determines pong response according to the spec``(): unit = 113 | let jid = JID("room@conference.example.com/me") 114 | let pongResponse = XMPPIq(XMPPIq.IqTypes.result, "myTest") 115 | pongResponse.SetAttributeValue(From, jid.FullJid) 116 | 117 | Assert.True(SharpXmppHelper.isPong jid "myTest" pongResponse) 118 | Assert.False(SharpXmppHelper.isPong jid "thyTest" pongResponse) 119 | -------------------------------------------------------------------------------- /Emulsion.Tests/Xmpp/SharpXmppPingHandlerTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.Xmpp.SharpXmppPingHandlerTests 6 | 7 | open System.IO 8 | open System.Xml 9 | 10 | open SharpXMPP 11 | open SharpXMPP.XMPP 12 | open SharpXMPP.XMPP.Client.Elements 13 | open Xunit 14 | 15 | open Emulsion.Xmpp 16 | open Emulsion.Xmpp.SharpXmppHelper.Attributes 17 | 18 | let private handler = SharpXmppPingHandler() 19 | type private MockedXmppTcpConnection() as this = 20 | inherit XmppTcpConnection("", JID(), "") 21 | do this.Writer <- XmlWriter.Create Stream.Null 22 | 23 | [] 24 | let ``SharpXmppPingHandler handles a ping request``() = 25 | let jid = JID "me@example.com" 26 | let request = SharpXmppHelper.ping jid "test" 27 | request.SetAttributeValue(From, "they@example.com") 28 | 29 | use connection = new MockedXmppTcpConnection() 30 | Assert.True(handler.Handle(connection, request)) 31 | 32 | [] 33 | let ``SharpXmppPingHandler sends a pong response``() = 34 | let jid = JID "me@example.com" 35 | let request = SharpXmppHelper.ping jid "test" 36 | request.SetAttributeValue(From, "they@example.com") 37 | 38 | let elements = ResizeArray() 39 | use connection = new MockedXmppTcpConnection() 40 | connection.add_Element(fun _ e -> elements.Add e.Stanza) 41 | 42 | Assert.True(handler.Handle(connection, request)) 43 | let pong = Seq.exactlyOne elements 44 | Assert.True(SharpXmppHelper.isPong jid "test" (pong :?> XMPPIq)) 45 | 46 | [] 47 | let ``SharpXmppPingHandler ignores a non-ping query``() = 48 | let elements = ResizeArray() 49 | use connection = new MockedXmppTcpConnection() 50 | connection.add_Element(fun _ e -> elements.Add e.Stanza) 51 | 52 | Assert.False(handler.Handle(connection, XMPPIq(XMPPIq.IqTypes.get))) 53 | Assert.Empty elements 54 | -------------------------------------------------------------------------------- /Emulsion.Tests/Xmpp/XmppClientFactory.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Tests.Xmpp 6 | 7 | open Emulsion.Xmpp.XmppClient 8 | 9 | type XmppClientFactory = 10 | static member create(?connect, 11 | ?joinMultiUserChat, 12 | ?send, 13 | ?sendIqQuery, 14 | ?addConnectionFailedHandler, 15 | ?addPresenceHandler, 16 | ?addMessageHandler): IXmppClient = 17 | let connect = defaultArg connect <| fun () -> async { return () } 18 | let joinMultiUserChat = defaultArg joinMultiUserChat <| fun _ _ _ -> () 19 | let send = defaultArg send ignore 20 | let addConnectionFailedHandler = defaultArg addConnectionFailedHandler <| fun _ _ -> () 21 | let sendIqQuery = defaultArg sendIqQuery <| fun _ _ _ -> () 22 | let addPresenceHandler = defaultArg addPresenceHandler <| fun _ _ -> () 23 | let addMessageHandler = defaultArg addMessageHandler <| fun _ _ -> () 24 | { new IXmppClient with 25 | member _.Connect() = connect() 26 | member _.JoinMultiUserChat roomJid nickname password = joinMultiUserChat roomJid nickname password 27 | member _.Send m = send m 28 | member _.SendIqQuery lt iq handler = sendIqQuery lt iq handler 29 | member _.AddConnectionFailedHandler lt handler = addConnectionFailedHandler lt handler 30 | member _.AddSignedInHandler _ _ = () 31 | member _.AddElementHandler _ _ = () 32 | member _.AddPresenceHandler lt handler = addPresenceHandler lt handler 33 | member _.AddMessageHandler lt handler = addMessageHandler lt handler 34 | } 35 | -------------------------------------------------------------------------------- /Emulsion.Tests/Xmpp/XmppClientTests.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Tests.Xmpp.XmppClientTests 6 | 7 | open System 8 | open System.Threading.Tasks 9 | open System.Xml.Linq 10 | 11 | open JetBrains.Lifetimes 12 | open SharpXMPP 13 | open SharpXMPP.XMPP 14 | open SharpXMPP.XMPP.Client.Elements 15 | open Xunit 16 | 17 | open Emulsion.Xmpp 18 | open Emulsion.Xmpp.SharpXmppHelper.Elements 19 | 20 | let private createErrorMessage (message: XElement) errorXml = 21 | // An error message is an exact copy of the original with the "error" element added: 22 | let errorMessage = XMPPMessage() 23 | message.Attributes() |> Seq.iter (fun a -> errorMessage.SetAttributeValue(a.Name, a.Value)) 24 | message.Elements() |> Seq.iter errorMessage.Add 25 | 26 | let error = XElement Error 27 | let errorChild = XElement.Parse errorXml 28 | error.Add errorChild 29 | errorMessage.Add error 30 | errorMessage 31 | 32 | [] 33 | let ``connect function calls the Connect method of the client passed``(): unit = 34 | let mutable connectCalled = false 35 | let client = XmppClientFactory.create(fun () -> async { connectCalled <- true }) 36 | Async.RunSynchronously <| XmppClient.connect client |> ignore 37 | Assert.True connectCalled 38 | 39 | [] 40 | let ``connect function returns a lifetime terminated whenever the ConnectionFailed callback is triggered``(): unit = 41 | let mutable callback = ignore 42 | let client = XmppClientFactory.create(addConnectionFailedHandler = fun _ h -> callback <- h) 43 | let lt = Async.RunSynchronously <| XmppClient.connect client 44 | Assert.True lt.IsAlive 45 | callback(ConnFailedArgs()) 46 | Assert.False lt.IsAlive 47 | 48 | let private sendRoomMessage client lt messageInfo = 49 | XmppClient.sendRoomMessage client lt Emulsion.Settings.defaultMessageTimeout messageInfo 50 | 51 | [] 52 | let ``sendRoomMessage calls Send method on the client``(): unit = 53 | let mutable message = Unchecked.defaultof 54 | let client = XmppClientFactory.create(send = fun m -> message <- m :?> XMPPMessage) 55 | let messageInfo = { RecipientJid = JID("room@conference.example.org"); Text = "foo bar" } 56 | Lifetime.Using(fun lt -> 57 | Async.RunSynchronously <| sendRoomMessage client lt messageInfo |> ignore 58 | Assert.Equal(messageInfo.RecipientJid.FullJid, message.To.FullJid) 59 | Assert.Equal(messageInfo.Text, message.Text) 60 | ) 61 | 62 | [] 63 | let ``sendRoomMessage's result gets resolved after the message receival``(): unit = 64 | let mutable messageHandler = ignore 65 | let mutable message = Unchecked.defaultof 66 | let client = 67 | XmppClientFactory.create( 68 | addMessageHandler = (fun _ h -> messageHandler <- h), 69 | send = fun m -> message <- m :?> XMPPMessage 70 | ) 71 | let messageInfo = { RecipientJid = JID("room@conference.example.org"); Text = "foo bar" } 72 | Lifetime.Using(fun lt -> 73 | let deliveryInfo = Async.RunSynchronously <| sendRoomMessage client lt messageInfo 74 | Assert.Equal(message.ID, deliveryInfo.MessageId) 75 | let deliveryTask = Async.StartAsTask deliveryInfo.Delivery 76 | Assert.False deliveryTask.IsCompleted 77 | messageHandler message 78 | deliveryTask.Wait() 79 | ) 80 | 81 | [] 82 | let ``sendRoomMessage's result doesn't get resolved after receiving other message``(): unit = 83 | let mutable messageHandler = ignore 84 | let client = XmppClientFactory.create(addMessageHandler = fun _ h -> messageHandler <- h) 85 | let messageInfo = { RecipientJid = JID("room@conference.example.org"); Text = "foo bar" } 86 | Lifetime.Using(fun lt -> 87 | let deliveryInfo = Async.RunSynchronously <| sendRoomMessage client lt messageInfo 88 | let deliveryTask = Async.StartAsTask deliveryInfo.Delivery 89 | Assert.False deliveryTask.IsCompleted 90 | 91 | let otherMessage = SharpXmppHelper.message "xxx" "nickname@example.org" "foo bar" 92 | messageHandler otherMessage 93 | Assert.False deliveryTask.IsCompleted 94 | ) 95 | 96 | [] 97 | let ``sendRoomMessage's result gets resolved with an error if an error response is received``(): unit = 98 | let mutable messageHandler = ignore 99 | let client = 100 | XmppClientFactory.create( 101 | addMessageHandler = (fun _ h -> messageHandler <- h), 102 | send = fun m -> messageHandler(createErrorMessage m "") 103 | ) 104 | let messageInfo = { RecipientJid = JID("room@conference.example.org"); Text = "foo bar" } 105 | Lifetime.Using(fun lt -> 106 | let deliveryInfo = Async.RunSynchronously <| sendRoomMessage client lt messageInfo 107 | let ae = Assert.Throws(fun () -> Async.RunSynchronously deliveryInfo.Delivery) 108 | let ex = Seq.exactlyOne ae.InnerExceptions 109 | Assert.Contains("", ex.Message) 110 | ) 111 | 112 | [] 113 | let ``sendRoomMessage's result gets terminated after parent lifetime termination``(): unit = 114 | let client = XmppClientFactory.create() 115 | let messageInfo = { RecipientJid = JID("room@conference.example.org"); Text = "foo bar" } 116 | use ld = Lifetime.Define() 117 | let lt = ld.Lifetime 118 | let deliveryInfo = Async.RunSynchronously <| sendRoomMessage client lt messageInfo 119 | let deliveryTask = Async.StartAsTask deliveryInfo.Delivery 120 | Assert.False deliveryTask.IsCompleted 121 | ld.Terminate() 122 | Assert.Throws(deliveryTask.GetAwaiter().GetResult) |> ignore 123 | 124 | [] 125 | let ``awaitMessageDelivery just returns an async from the delivery info``(): unit = 126 | let async = async { return () } 127 | let deliveryInfo = { MessageId = ""; Delivery = async } 128 | let result = XmppClient.awaitMessageDelivery deliveryInfo 129 | Assert.True(Object.ReferenceEquals(async, result)) 130 | 131 | [] 132 | let ``awaitMessageDelivery should throw an error on timeout``(): unit = 133 | let client = XmppClientFactory.create() 134 | let messageInfo = { RecipientJid = JID("room@conference.example.org"); Text = "foo bar" } 135 | use ld = Lifetime.Define() 136 | let lt = ld.Lifetime 137 | let deliveryInfo = Async.RunSynchronously <| XmppClient.sendRoomMessage client lt TimeSpan.Zero messageInfo 138 | let deliveryTask = XmppClient.awaitMessageDelivery deliveryInfo 139 | Assert.Throws(fun () -> Async.RunSynchronously deliveryTask) |> ignore 140 | -------------------------------------------------------------------------------- /Emulsion.Tests/Xmpp/XmppMessageFactory.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Tests.Xmpp 6 | 7 | open System.Xml.Linq 8 | open SharpXMPP.XMPP.Client.Elements 9 | 10 | open Emulsion.Xmpp.SharpXmppHelper.Attributes 11 | open Emulsion.Xmpp.SharpXmppHelper.Elements 12 | 13 | type XmppMessageFactory = 14 | static member create(?senderJid: string, ?text: string, ?delayDate: string, ?messageType: string): XMPPMessage = 15 | let element = XMPPMessage() 16 | senderJid |> Option.iter (fun from -> 17 | element.SetAttributeValue(From, from) 18 | ) 19 | text |> Option.iter (fun t -> 20 | element.Text <- t 21 | ) 22 | delayDate |> Option.iter (fun date -> 23 | let delay = XElement(Delay) 24 | delay.SetAttributeValue(Stamp, date) 25 | element.Add(delay) 26 | ) 27 | messageType |> Option.iter (fun mt -> 28 | element.SetAttributeValue(Type, mt) 29 | ) 30 | 31 | element 32 | -------------------------------------------------------------------------------- /Emulsion.Web/ContentController.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Web 6 | 7 | open System 8 | open System.Threading.Tasks 9 | 10 | open Microsoft.AspNetCore.Mvc 11 | open Microsoft.Extensions.Logging 12 | 13 | open Emulsion.ContentProxy 14 | open Emulsion.Database 15 | open Emulsion.Database.Entities 16 | open Emulsion.Settings 17 | open Emulsion.Telegram 18 | 19 | [] 20 | [] 21 | type ContentController(logger: ILogger, 22 | configuration: HostingSettings, 23 | telegram: ITelegramClient, 24 | fileCache: Func, 25 | context: EmulsionDbContext) = 26 | inherit ControllerBase() 27 | 28 | let decodeHashId hashId = 29 | try 30 | Some <| Proxy.decodeHashId configuration.HashIdSalt hashId 31 | with 32 | | ex -> 33 | logger.LogWarning(ex, "Error during hashId deserializing") 34 | None 35 | 36 | [] 37 | member this.Get(hashId: string): Task = task { 38 | match decodeHashId hashId with 39 | | None -> 40 | logger.LogWarning $"Cannot decode hash id: \"{hashId}\"." 41 | return this.BadRequest() 42 | | Some contentId -> 43 | match! ContentStorage.getById context contentId with 44 | | None -> 45 | logger.LogWarning $"Content \"{contentId}\" not found in content storage." 46 | return this.NotFound() :> IActionResult 47 | | Some content -> 48 | match fileCache.Invoke() with 49 | | None -> 50 | match content.ChatUserName with 51 | | "" -> return UnprocessableEntityResult() 52 | | _ -> 53 | let link = $"https://t.me/{content.ChatUserName}/{string content.MessageId}" 54 | return RedirectResult link 55 | | Some cache -> 56 | match! telegram.GetFileInfo content.FileId with 57 | | None -> 58 | logger.LogWarning $"File \"{content.FileId}\" could not be found on Telegram server." 59 | return this.NotFound() :> IActionResult 60 | | Some fileInfo -> 61 | match! cache.Download(fileInfo.TemporaryLink, content.FileId, fileInfo.Size) with 62 | | None -> 63 | logger.LogWarning $"Link \"{fileInfo}\" could not be downloaded." 64 | return this.NotFound() :> IActionResult 65 | | Some stream -> 66 | match content.MimeType with 67 | | "application/octet-stream" -> return FileStreamResult(stream, content.MimeType, FileDownloadName = content.FileName) 68 | | _ -> return FileStreamResult(stream, content.MimeType) 69 | } 70 | -------------------------------------------------------------------------------- /Emulsion.Web/Emulsion.Web.fsproj: -------------------------------------------------------------------------------- 1 | 6 | 7 | 8 | 9 | Library 10 | net9.0 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /Emulsion.Web/HistoryController.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Web 6 | 7 | open System 8 | open System.Collections.Generic 9 | open System.Threading.Tasks 10 | 11 | open Microsoft.AspNetCore.Mvc 12 | open Microsoft.EntityFrameworkCore 13 | 14 | open Emulsion.Database 15 | open Emulsion.Database.Entities 16 | 17 | type MessageStatistics = { 18 | MessageCount: int 19 | } 20 | 21 | type Message = { 22 | MessageSystemId: string 23 | Sender: string 24 | DateTime: DateTimeOffset 25 | Text: string 26 | } 27 | 28 | [] 29 | [] 30 | type HistoryController(context: EmulsionDbContext) = 31 | inherit ControllerBase() 32 | 33 | let convertMessage(entry: ArchiveEntry) = 34 | { 35 | MessageSystemId = entry.MessageSystemId 36 | Sender = entry.Sender 37 | DateTime = entry.DateTime 38 | Text = entry.Text 39 | } 40 | 41 | [] 42 | member this.GetStatistics(): Task = task { 43 | let! count = context.ArchiveEntries.CountAsync() 44 | return { 45 | MessageCount = count 46 | } 47 | } 48 | 49 | [] 50 | member this.GetMessages(offset: int, limit: int): Task> = task { 51 | let! messages = 52 | (query { 53 | for entry in context.ArchiveEntries do 54 | sortBy entry.Id 55 | skip offset 56 | take limit 57 | }).ToListAsync() 58 | return messages |> Seq.map convertMessage 59 | } 60 | -------------------------------------------------------------------------------- /Emulsion.Web/WebServer.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Web.WebServer 6 | 7 | open System 8 | open System.IO 9 | open System.Reflection 10 | open System.Threading.Tasks 11 | 12 | open Microsoft.AspNetCore.Builder 13 | open Microsoft.Extensions.DependencyInjection 14 | open Microsoft.Extensions.FileProviders 15 | open Serilog 16 | 17 | open Emulsion.ContentProxy 18 | open Emulsion.Database 19 | open Emulsion.Settings 20 | open Emulsion.Telegram 21 | 22 | let run (logger: ILogger) 23 | (hostingSettings: HostingSettings) 24 | (databaseSettings: DatabaseSettings) 25 | (messageArchiveSettings: MessageArchiveSettings) 26 | (telegram: ITelegramClient) 27 | (fileCache: FileCache option) 28 | : Task = 29 | let builder = WebApplication.CreateBuilder(WebApplicationOptions()) 30 | if messageArchiveSettings.IsEnabled then 31 | builder.Environment.WebRootPath <- 32 | let assemblyPath = Assembly.GetEntryAssembly().Location 33 | let appDirectory = Path.GetDirectoryName assemblyPath 34 | Path.Combine(appDirectory, "wwwroot") 35 | builder.Environment.WebRootFileProvider <- new PhysicalFileProvider(builder.Environment.WebRootPath) 36 | 37 | builder.Host.UseSerilog(logger) 38 | 39 | |> ignore 40 | 41 | builder.Services 42 | .AddSingleton(hostingSettings) 43 | .AddSingleton(telegram) 44 | .AddSingleton>(Func<_>(fun () -> fileCache)) 45 | .AddTransient(fun _ -> new EmulsionDbContext(databaseSettings.ContextOptions)) 46 | .AddControllers() 47 | .AddApplicationPart(typeof.Assembly) 48 | |> ignore 49 | 50 | let app = builder.Build() 51 | app.MapControllers() |> ignore 52 | if messageArchiveSettings.IsEnabled then 53 | app.UseStaticFiles() 54 | |> ignore 55 | app.RunAsync(hostingSettings.BindUri) 56 | -------------------------------------------------------------------------------- /Emulsion.sln.DotSettings: -------------------------------------------------------------------------------- 1 |  2 | True 3 | True 4 | True 5 | True 6 | True 7 | True 8 | True -------------------------------------------------------------------------------- /Emulsion.sln.license: -------------------------------------------------------------------------------- 1 | SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | 3 | SPDX-License-Identifier: MIT 4 | -------------------------------------------------------------------------------- /Emulsion/Emulsion.fsproj: -------------------------------------------------------------------------------- 1 | 6 | 7 | 8 | 9 | Exe 10 | net9.0 11 | 4.0.0 12 | Major 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | -------------------------------------------------------------------------------- /Emulsion/ExceptionUtils.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.ExceptionUtils 6 | 7 | open System.Runtime.ExceptionServices 8 | 9 | let reraise (ex: exn): 'a = 10 | let edi = ExceptionDispatchInfo.Capture ex 11 | edi.Throw() 12 | failwith "Impossible" 13 | -------------------------------------------------------------------------------- /Emulsion/Lifetimes.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Lifetimes 6 | 7 | open System.Threading.Tasks 8 | 9 | open JetBrains.Lifetimes 10 | 11 | let awaitTermination(lifetime: Lifetime): Async = 12 | let tcs = TaskCompletionSource() 13 | lifetime.OnTermination(fun () -> tcs.SetResult()) |> ignore 14 | Async.AwaitTask tcs.Task 15 | -------------------------------------------------------------------------------- /Emulsion/Logging.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Logging 6 | 7 | open System.IO 8 | 9 | open JetBrains.Diagnostics 10 | open Serilog 11 | open Serilog.Core 12 | open Serilog.Events 13 | open Serilog.Filters 14 | 15 | open Emulsion.Settings 16 | open Serilog.Formatting.Json 17 | 18 | type private EventCategory = 19 | Telegram | Xmpp 20 | 21 | let private EventCategoryProperty = "EventCategory" 22 | 23 | let private loggerWithCategory (category: EventCategory) (logger: ILogger) = 24 | let enricher = 25 | { new ILogEventEnricher with 26 | member _.Enrich(logEvent, propertyFactory) = 27 | logEvent.AddPropertyIfAbsent(propertyFactory.CreateProperty(EventCategoryProperty, category)) } 28 | logger.ForContext enricher 29 | 30 | let telegramLogger: ILogger -> ILogger = loggerWithCategory Telegram 31 | let xmppLogger: ILogger -> ILogger = loggerWithCategory Xmpp 32 | 33 | let createRootLogger (settings: LogSettings) = 34 | let addFileLogger (category: EventCategory option) fileName (config: LoggerConfiguration) = 35 | let filePath = Path.Combine(settings.Directory, fileName) 36 | config.WriteTo.Logger(fun subConfig -> 37 | let filtered = 38 | match category with 39 | | Some c -> 40 | let scalar = c.ToString() // required because log event properties are actually converted to strings 41 | subConfig.Filter.ByIncludingOnly(Matching.WithProperty(EventCategoryProperty, scalar)) 42 | | None -> subConfig.Filter.ByExcluding(Matching.WithProperty EventCategoryProperty) 43 | 44 | filtered.WriteTo.RollingFile(JsonFormatter(), filePath) 45 | |> ignore 46 | ) 47 | 48 | let config = 49 | LoggerConfiguration() 50 | .MinimumLevel.Information() 51 | .WriteTo.Console() 52 | |> addFileLogger (Some Telegram) "telegram.log" 53 | |> addFileLogger (Some Xmpp) "xmpp.log" 54 | |> addFileLogger None "system.log" 55 | config.CreateLogger() 56 | 57 | let private toSerilog(level: LoggingLevel): LogEventLevel voption = 58 | match level with 59 | | LoggingLevel.OFF -> ValueNone 60 | | LoggingLevel.FATAL -> ValueSome LogEventLevel.Fatal 61 | | LoggingLevel.ERROR -> ValueSome LogEventLevel.Error 62 | | LoggingLevel.WARN -> ValueSome LogEventLevel.Warning 63 | | LoggingLevel.INFO -> ValueSome LogEventLevel.Information 64 | | LoggingLevel.VERBOSE -> ValueSome LogEventLevel.Verbose 65 | | LoggingLevel.TRACE -> ValueSome LogEventLevel.Debug 66 | | _ -> ValueSome LogEventLevel.Error // convert any unknown ones to error 67 | 68 | let attachToRdLogSystem(serilog: ILogger) = 69 | Log.UsingLogFactory({ 70 | new ILogFactory with 71 | override this.GetLog(category) = 72 | let serilogLogger = serilog.ForContext(Constants.SourceContextPropertyName, category) 73 | { 74 | new ILog with 75 | override this.IsEnabled(level) = 76 | toSerilog level 77 | |> ValueOption.map serilogLogger.IsEnabled 78 | |> ValueOption.defaultValue false 79 | override this.Log(level, message, ``exception``) = 80 | toSerilog level 81 | |> ValueOption.iter(fun level -> 82 | serilogLogger.Write(level, ``exception``, message) 83 | ) 84 | override this.Category = category 85 | } 86 | }) 87 | -------------------------------------------------------------------------------- /Emulsion/MessageArchive.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion 6 | 7 | open System 8 | 9 | open Emulsion.Database 10 | open Emulsion.Database.Entities 11 | open Emulsion.Messaging 12 | 13 | type IMessageArchive = 14 | abstract member Archive: IncomingMessage -> Async 15 | 16 | type MessageArchive(database: DatabaseSettings) = 17 | 18 | let convert message = 19 | let body, messageSystemId = 20 | match message with 21 | | XmppMessage msg -> msg, "XMPP" 22 | | TelegramMessage msg -> msg, "Telegram" 23 | let sender, text = 24 | match body with 25 | | Authored msg -> msg.author, msg.text 26 | | Event e -> "", e.text 27 | 28 | { 29 | Id = 0L 30 | MessageSystemId = messageSystemId 31 | DateTime = DateTimeOffset.UtcNow 32 | Sender = sender 33 | Text = text 34 | } 35 | 36 | interface IMessageArchive with 37 | member _.Archive(message: IncomingMessage): Async = 38 | let message = convert message 39 | DataStorage.transaction database (fun context -> 40 | DataStorage.addAsync context.ArchiveEntries message 41 | ) 42 | -------------------------------------------------------------------------------- /Emulsion/MessagingCore.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion 6 | 7 | open System 8 | open System.Threading.Channels 9 | open System.Threading.Tasks 10 | open Emulsion.Messaging 11 | open Emulsion.Messaging.MessageSystem 12 | open JetBrains.Collections.Viewable 13 | open JetBrains.Lifetimes 14 | open Microsoft.FSharp.Core 15 | open Serilog 16 | 17 | type MessagingCore( 18 | lifetime: Lifetime, 19 | logger: ILogger, 20 | archive: IMessageArchive option 21 | ) = 22 | let messageProcessedSuccessfully = Signal() 23 | let processMessage telegram xmpp message ct = 24 | task { 25 | match archive with 26 | | Some a -> do! Async.StartAsTask(a.Archive message, cancellationToken = ct) 27 | | None -> () 28 | 29 | match message with 30 | | TelegramMessage msg -> putMessage xmpp (OutgoingMessage msg) 31 | | XmppMessage msg -> putMessage telegram (OutgoingMessage msg) 32 | 33 | messageProcessedSuccessfully.Fire(()) 34 | } 35 | 36 | let messages = Channel.CreateUnbounded() 37 | do lifetime.OnTermination(fun () -> messages.Writer.Complete()) |> ignore 38 | 39 | let messageProcessingError = Signal() 40 | let processLoop telegram xmpp: Task = task { 41 | logger.Information("Core workflow starting.") 42 | 43 | let ct = lifetime.ToCancellationToken() 44 | while lifetime.IsAlive do 45 | try 46 | let! m = messages.Reader.ReadAsync ct 47 | do! lifetime.ExecuteAsync(fun() -> processMessage telegram xmpp m ct) 48 | with 49 | | :? OperationCanceledException -> () 50 | | error -> 51 | logger.Error(error, "Core workflow exception.") 52 | messageProcessingError.Fire(()) 53 | 54 | logger.Information("Core workflow terminating.") 55 | } 56 | 57 | let messageCannotBeReceived = Signal() 58 | member _.MessageProcessedSuccessfully: ISource = messageProcessedSuccessfully 59 | member _.MessageCannotBeReceived: ISource = messageCannotBeReceived 60 | member _.MessageProcessingError: ISource = messageProcessingError 61 | member val ProcessingTask = None with get, set 62 | 63 | member this.Start(telegram: IMessageSystem, xmpp: IMessageSystem) = 64 | this.ProcessingTask <- Some(Task.Run(fun() -> processLoop telegram xmpp)) 65 | 66 | member _.ReceiveMessage(message: IncomingMessage): unit = 67 | let result = messages.Writer.TryWrite message 68 | if not result then 69 | logger.Error("Write status to core channel should always be true, but it is {Status}.", result) 70 | messageCannotBeReceived.Fire(()) 71 | -------------------------------------------------------------------------------- /Emulsion/Program.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | module Emulsion.Program 6 | 7 | open System 8 | open System.IO 9 | open System.Security.Cryptography 10 | 11 | open JetBrains.Lifetimes 12 | open Microsoft.Extensions.Configuration 13 | open Serilog 14 | 15 | open Emulsion.ContentProxy 16 | open Emulsion.Database 17 | open Emulsion.Messaging.MessageSystem 18 | open Emulsion.Settings 19 | open Emulsion.Web 20 | open Emulsion.Xmpp 21 | 22 | let private getConfiguration directory (fileName: string) = 23 | let config = 24 | ConfigurationBuilder() 25 | .SetBasePath(directory) 26 | .AddJsonFile(fileName) 27 | .Build() 28 | read config 29 | 30 | let private migrateDatabase (logger: ILogger) (settings: DatabaseSettings) = async { 31 | logger.Information("Migrating the database {DataSource}…", settings.DataSource) 32 | use context = new EmulsionDbContext(settings.ContextOptions) 33 | do! DataStorage.initializeDatabase context 34 | logger.Information "Database migration completed." 35 | } 36 | 37 | let private serviceContext logger = { 38 | RestartCooldown = TimeSpan.FromSeconds(30.0) // TODO[F]: Customize through the config. 39 | Logger = logger 40 | } 41 | 42 | let private startMessageSystem (logger: ILogger) (system: IMessageSystem) receiver = 43 | Async.StartChild <| async { 44 | do! Async.SwitchToNewThread() 45 | try 46 | system.RunSynchronously receiver 47 | with 48 | | ex -> logger.Error(ex, "Message system error in {System}", system) 49 | } 50 | 51 | let private startApp config = 52 | async { 53 | let logger = Logging.createRootLogger config.Log 54 | use _ = Logging.attachToRdLogSystem logger 55 | try 56 | let xmppLogger = Logging.xmppLogger logger 57 | let telegramLogger = Logging.telegramLogger logger 58 | 59 | let! cancellationToken = Async.CancellationToken 60 | let xmpp = XmppMessageSystem(serviceContext xmppLogger, cancellationToken, config.Xmpp) 61 | let telegram = Telegram.Client(serviceContext telegramLogger, 62 | cancellationToken, 63 | config.Telegram, 64 | config.Database, 65 | config.Hosting) 66 | 67 | use sha256 = SHA256.Create() 68 | let fileCacheOption = config.FileCache |> Option.map(fun settings -> 69 | let httpClientFactory = SimpleHttpClientFactory() 70 | new FileCache(logger, settings, httpClientFactory, sha256) 71 | ) 72 | 73 | try 74 | match config.Database with 75 | | Some dbSettings -> do! migrateDatabase logger dbSettings 76 | | None -> () 77 | 78 | let webServerTask = 79 | match config.Hosting, config.Database with 80 | | Some hosting, Some database -> 81 | logger.Information "Initializing the web server…" 82 | Some <| WebServer.run logger hosting database config.MessageArchive telegram fileCacheOption 83 | | _ -> None 84 | 85 | logger.Information "Core preparation…" 86 | let archive = 87 | match config.Database, config.MessageArchive.IsEnabled with 88 | | Some database, true -> Some(MessageArchive database :> IMessageArchive) 89 | | _ -> None 90 | use lt = Lifetime.Define "app" 91 | let core = MessagingCore(lt.Lifetime, logger, archive) 92 | logger.Information "Message systems preparation…" 93 | let! telegramSystem = startMessageSystem logger telegram core.ReceiveMessage 94 | let! xmppSystem = startMessageSystem logger xmpp core.ReceiveMessage 95 | logger.Information "Starting the core…" 96 | core.Start(telegram, xmpp) 97 | logger.Information "System ready" 98 | 99 | logger.Information "Waiting for the systems to terminate…" 100 | do! Async.Ignore <| Async.Parallel(seq { 101 | yield telegramSystem 102 | yield xmppSystem 103 | 104 | match webServerTask with 105 | | Some task -> yield Async.AwaitTask task 106 | | None -> () 107 | }) 108 | finally 109 | fileCacheOption |> Option.iter(fun x -> (x :> IDisposable).Dispose()) 110 | logger.Information "Terminated successfully." 111 | with 112 | | error -> 113 | logger.Fatal(error, "General application failure") 114 | } 115 | 116 | let private runApp app = 117 | Async.RunSynchronously app 118 | 0 119 | 120 | let private defaultConfigFileName = "emulsion.json" 121 | 122 | [] 123 | let main = function 124 | | [| |] -> 125 | getConfiguration (Directory.GetCurrentDirectory()) defaultConfigFileName 126 | |> startApp 127 | |> runApp 128 | | [| configPath |] -> 129 | let fullConfigPath = Path.GetFullPath configPath 130 | getConfiguration (Path.GetDirectoryName fullConfigPath) (Path.GetFileName configPath) 131 | |> startApp 132 | |> runApp 133 | | _ -> 134 | printfn $"Arguments: [config file name] ({defaultConfigFileName} by default)" 135 | 0 136 | -------------------------------------------------------------------------------- /Emulsion/Xmpp/EmulsionXmpp.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | /// Main business logic for an XMPP part of the Emulsion application. 6 | module Emulsion.Xmpp.EmulsionXmpp 7 | 8 | open System 9 | 10 | open JetBrains.Lifetimes 11 | open Serilog 12 | open SharpXMPP.XMPP 13 | 14 | open Emulsion 15 | open Emulsion.Messaging 16 | open Emulsion.Messaging.MessageSystem 17 | open Emulsion.Settings 18 | open Emulsion.Xmpp.XmppClient 19 | 20 | let private shouldProcessMessage (settings: XmppSettings) message = 21 | let isGroup = SharpXmppHelper.isGroupChatMessage message 22 | let shouldSkip = lazy ( 23 | SharpXmppHelper.isOwnMessage settings.Nickname message 24 | || SharpXmppHelper.isHistoricalMessage message 25 | || SharpXmppHelper.isEmptyMessage message 26 | ) 27 | isGroup && not shouldSkip.Value 28 | 29 | let private addMessageHandler (client: IXmppClient) lt settings receiver = 30 | client.AddMessageHandler lt (fun xmppMessage -> 31 | if shouldProcessMessage settings xmppMessage then 32 | let message = SharpXmppHelper.parseMessage xmppMessage 33 | receiver(XmppMessage message) 34 | ) 35 | 36 | let initializeLogging (logger: ILogger) (client: IXmppClient): IXmppClient = 37 | let lt = Lifetime.Eternal 38 | client.AddConnectionFailedHandler lt (fun e -> logger.Error(e.Exception, "Connection failed: {Message}", e.Message)) 39 | client.AddSignedInHandler lt (fun _ -> logger.Information("Signed in to the server")) 40 | client.AddElementHandler lt (fun e -> 41 | let direction = if e.IsInput then "incoming" else "outgoing" 42 | logger.Information("XMPP stanza ({Direction}): {Stanza}", direction, e.Stanza) 43 | ) 44 | client 45 | 46 | let private withTimeout title (logger: ILogger) workflow (timeout: TimeSpan) = async { 47 | logger.Information("Starting \"{Title}\" with timeout {Timeout}.", title, timeout) 48 | let! child = Async.StartChild(workflow, int timeout.TotalMilliseconds) 49 | 50 | let! childWaiter = Async.StartChild(async { 51 | let! result = child 52 | return Some(ValueSome result) 53 | }) 54 | 55 | let waitTime = timeout * 1.5 56 | let timeoutWaiter = async { 57 | do! Async.Sleep waitTime 58 | return Some ValueNone 59 | } 60 | 61 | let! completedInTime = Async.Choice [| childWaiter; timeoutWaiter |] 62 | match completedInTime with 63 | | Some(ValueSome r) -> return r 64 | | _ -> 65 | logger.Information( 66 | "Task {Title} neither complete nor cancelled in {Timeout}. Entering extended wait mode.", 67 | title, 68 | waitTime 69 | ) 70 | let! completedInTime = Async.Choice [| childWaiter; timeoutWaiter |] 71 | match completedInTime with 72 | | Some(ValueSome r) -> return r 73 | | _ -> 74 | logger.Warning( 75 | "Task {Title} neither complete nor cancelled in another {Timeout}. Trying to cancel forcibly by terminating the client.", 76 | title, 77 | waitTime 78 | ) 79 | return raise <| OperationCanceledException($"Operation \"%s{title}\" forcibly cancelled") 80 | } 81 | 82 | /// Outer async will establish a connection and enter the room, inner async will await for the room session 83 | /// termination. 84 | let run (settings: XmppSettings) 85 | (logger: ILogger) 86 | (client: IXmppClient) 87 | (messageReceiver: IncomingMessageReceiver): Async> = async { 88 | let! sessionLifetime = withTimeout "server connection" logger (connect client) settings.ConnectionTimeout 89 | sessionLifetime.ThrowIfNotAlive() 90 | logger.Information "Connection succeeded" 91 | 92 | logger.Information "Initializing client handler" 93 | addMessageHandler client sessionLifetime settings messageReceiver 94 | logger.Information "Client handler initialized" 95 | 96 | let roomInfo = { 97 | RoomJid = JID(settings.Room) 98 | Nickname = settings.Nickname 99 | Password = settings.RoomPassword 100 | Ping = {| Interval = settings.PingInterval 101 | Timeout = settings.PingTimeout |} 102 | } 103 | logger.Information("Entering the room {RoomInfo}", roomInfo) 104 | let! roomLifetime = enterRoom logger client sessionLifetime roomInfo 105 | logger.Information "Entered the room" 106 | 107 | return async { 108 | logger.Information "Ready, waiting for room lifetime termination" 109 | do! Lifetimes.awaitTermination roomLifetime 110 | logger.Information "Room lifetime has been terminated" 111 | } 112 | } 113 | 114 | let send (logger: ILogger) 115 | (client: IXmppClient) 116 | (lifetime: Lifetime) 117 | (settings: XmppSettings) 118 | (message: Message): Async = async { 119 | let text = 120 | match message with 121 | | Authored msg -> $"<{msg.author}> {msg.text}" 122 | | Event msg -> msg.text 123 | let message = { RecipientJid = JID(settings.Room); Text = text } 124 | let! deliveryInfo = sendRoomMessage client lifetime settings.MessageTimeout message 125 | logger.Information("Message {MessageId} has been sent; awaiting delivery", deliveryInfo.MessageId) 126 | do! awaitMessageDelivery deliveryInfo 127 | } 128 | -------------------------------------------------------------------------------- /Emulsion/Xmpp/SharpXmppClient.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | /// An implementation of an IXmppClient based on SharpXMPP library. 6 | module Emulsion.Xmpp.SharpXmppClient 7 | 8 | open SharpXMPP 9 | open SharpXMPP.XMPP 10 | 11 | open Emulsion.Xmpp 12 | open Emulsion.Xmpp.XmppClient 13 | open Emulsion.Settings 14 | 15 | type Wrapper(client: XmppClient) = 16 | let socketWriterLock = obj() 17 | 18 | interface IXmppClient with 19 | member _.Connect() = async { 20 | let! ct = Async.CancellationToken 21 | return! Async.AwaitTask(client.ConnectAsync ct) 22 | } 23 | member _.JoinMultiUserChat roomJid nickname password = SharpXmppHelper.joinRoom client roomJid.BareJid nickname password 24 | member _.Send message = 25 | lock socketWriterLock (fun () -> 26 | client.Send message 27 | ) 28 | member this.SendIqQuery lt iq handler = 29 | lock socketWriterLock (fun () -> 30 | client.Query(iq, fun response -> lt.Execute(fun() -> handler response)) 31 | ) 32 | member _.AddSignedInHandler lt handler = 33 | let handlerDelegate = XmppClient.SignedInHandler(fun _ -> handler) 34 | client.add_SignedIn handlerDelegate 35 | lt.OnTermination(fun () -> client.remove_SignedIn handlerDelegate) |> ignore 36 | member _.AddElementHandler lt handler = 37 | let handlerDelegate = XmppClient.ElementHandler(fun _ -> handler) 38 | client.add_Element handlerDelegate 39 | lt.OnTermination(fun () -> client.remove_Element handlerDelegate) |> ignore 40 | member _.AddConnectionFailedHandler lt handler = 41 | let handlerDelegate = XmppClient.ConnectionFailedHandler(fun _ -> handler) 42 | client.add_ConnectionFailed handlerDelegate 43 | lt.OnTermination(fun () -> client.remove_ConnectionFailed handlerDelegate) |> ignore 44 | member _.AddPresenceHandler lt handler = 45 | let handlerDelegate = XmppClient.PresenceHandler(fun _ -> handler) 46 | client.add_Presence handlerDelegate 47 | lt.OnTermination(fun () -> client.remove_Presence handlerDelegate) |> ignore 48 | member _.AddMessageHandler lt handler = 49 | let handlerDelegate = XmppClient.MessageHandler(fun _ -> handler) 50 | client.add_Message handlerDelegate 51 | lt.OnTermination(fun () -> client.remove_Message handlerDelegate) |> ignore 52 | 53 | let create (settings: XmppSettings): XmppClient = 54 | let client = new XmppClient(JID(settings.Login), settings.Password) 55 | client.IqManager.PayloadHandlers.Add(SharpXmppPingHandler()) 56 | client 57 | 58 | let wrap(client: XmppClient): IXmppClient = 59 | Wrapper client 60 | -------------------------------------------------------------------------------- /Emulsion/Xmpp/SharpXmppHelper.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2025 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | /// Helper functions to deal with SharpXMPP low-level details (such as XML stuff). 6 | module Emulsion.Xmpp.SharpXmppHelper 7 | 8 | open System 9 | open System.Buffers 10 | open System.Text 11 | open System.Xml.Linq 12 | 13 | open Microsoft.FSharp.NativeInterop 14 | open SharpXMPP 15 | open SharpXMPP.XMPP 16 | open SharpXMPP.XMPP.Client.Elements 17 | open SharpXMPP.XMPP.Client.MUC.Bookmarks.Elements 18 | 19 | open Emulsion.Messaging 20 | open Emulsion.Xmpp 21 | 22 | module Namespaces = 23 | let MucUser = "http://jabber.org/protocol/muc#user" 24 | let Ping = "urn:xmpp:ping" 25 | 26 | module Attributes = 27 | let Code = XName.Get "code" 28 | let From = XName.Get "from" 29 | let Id = XName.Get "id" 30 | let Stamp = XName.Get "stamp" 31 | let To = XName.Get "to" 32 | let Type = XName.Get "type" 33 | 34 | open Attributes 35 | 36 | module Elements = 37 | let Body = XName.Get("body", Namespaces.JabberClient) 38 | let Delay = XName.Get("delay", "urn:xmpp:delay") 39 | let Error = XName.Get("error", Namespaces.JabberClient) 40 | let Nick = XName.Get("nick", Namespaces.StorageBookmarks) 41 | let Password = XName.Get("password", Namespaces.StorageBookmarks) 42 | let Ping = XName.Get("ping", Namespaces.Ping) 43 | let Status = XName.Get("status", Namespaces.MucUser) 44 | let X = XName.Get("x", Namespaces.MucUser) 45 | 46 | open Elements 47 | 48 | let private bookmark (roomJid: string) (nickname: string) (password: string option): BookmarkedConference = 49 | let room = BookmarkedConference(JID = JID roomJid) 50 | password |> Option.iter (fun p -> room.Password <- p) 51 | let nickElement = XElement(Nick, Value = nickname) 52 | room.Add(nickElement) 53 | room 54 | 55 | #nowarn 9 // for NativePtr 56 | let SanitizeXmlText(text: string): string = 57 | let mutable hasError = false 58 | let mutable span = text.AsSpan() 59 | while not hasError && not span.IsEmpty do 60 | let mutable rune = Rune() 61 | let mutable consumed = 0 62 | if Rune.DecodeFromUtf16(span, &rune, &consumed) = OperationStatus.Done 63 | then span <- span.Slice consumed 64 | else hasError <- true 65 | 66 | if hasError then 67 | let builder = StringBuilder() 68 | for r in text.EnumerateRunes() do 69 | let length = r.Utf16SequenceLength 70 | let buf = Span(NativePtr.stackalloc length |> NativePtr.toVoidPtr, length) 71 | r.EncodeToUtf16 buf |> ignore 72 | builder.Append(buf) |> ignore 73 | builder.ToString() 74 | else 75 | text 76 | 77 | let joinRoom (client: XmppClient) (roomJid: string) (nickname: string) (password: string option): unit = 78 | let room = bookmark roomJid nickname password 79 | client.BookmarkManager.Join room 80 | 81 | let message (id: string) (toAddr: string) (text: string): XMPPMessage = 82 | let m = XMPPMessage() 83 | m.SetAttributeValue(Id, id) 84 | m.SetAttributeValue(Type, "groupchat") 85 | m.SetAttributeValue(To, toAddr) 86 | let body = XElement(Body) 87 | body.Value <- SanitizeXmlText text 88 | m.Add(body) 89 | m 90 | 91 | let ping (jid: JID) (id: string): XMPPIq = 92 | let iq = XMPPIq(XMPPIq.IqTypes.get, id, To = jid) 93 | iq.Add(XElement(Ping)) 94 | iq 95 | 96 | let isPing(iq: XMPPIq): bool = 97 | if iq.IqType <> XMPPIq.IqTypes.get then false 98 | else iq.Element Ping <> null 99 | 100 | let isPong (from: JID) (pingId: string) (iq: XMPPIq): bool = 101 | iq.IqType = XMPPIq.IqTypes.result && iq.From.FullJid = from.FullJid && iq.ID = pingId 102 | 103 | let private getAttributeValue (element : XElement) attributeName = 104 | let attribute = element.Attribute(attributeName) 105 | if isNull attribute 106 | then None 107 | else Some attribute.Value 108 | 109 | let private getResource jidText = JID(jidText).Resource 110 | 111 | let isOwnMessage (nickname : string) (message : XMPPMessage) : bool = 112 | getAttributeValue message From 113 | |> Option.map getResource 114 | |> Option.map(fun resource -> resource = nickname) 115 | |> Option.defaultValue false 116 | 117 | let isHistoricalMessage (message : XMPPMessage) : bool = 118 | not ( 119 | message.Elements Delay 120 | |> Seq.isEmpty 121 | ) 122 | 123 | let isGroupChatMessage(message: XMPPMessage): bool = 124 | let messageType = getAttributeValue message Type 125 | messageType = Some "groupchat" 126 | 127 | let isEmptyMessage(message: XMPPMessage): bool = 128 | String.IsNullOrWhiteSpace message.Text 129 | 130 | /// See https://xmpp.org/registrar/mucstatus.html 131 | let private removalCodes = Set.ofArray [| 301; 307; 321; 322; 332 |] 132 | let hasRemovalCode(states: int[]): bool = 133 | states |> Array.exists (fun x -> Set.contains x removalCodes) 134 | 135 | let getMessageId(message: XMPPMessage): string option = 136 | getAttributeValue message Id 137 | 138 | let getMessageError(message: XMPPMessage): XElement option = 139 | message.Element Error |> Option.ofObj 140 | 141 | let parseMessage (message: XMPPMessage): Message = 142 | let nickname = 143 | getAttributeValue message From 144 | |> Option.map getResource 145 | |> Option.defaultValue "[UNKNOWN USER]" 146 | Authored { author = nickname; text = message.Text } 147 | 148 | let parsePresence(presence: XMPPPresence): Presence = 149 | let from = getAttributeValue presence From |> Option.defaultValue "" 150 | let presenceType = getAttributeValue presence Type 151 | let states = 152 | presence.Element X 153 | |> Option.ofObj 154 | |> Option.map (fun x -> 155 | x.Elements Status 156 | |> Seq.choose (fun s -> getAttributeValue s Code) 157 | |> Seq.map int 158 | ) 159 | |> Option.map Seq.toArray 160 | |> Option.defaultWith(fun () -> Array.empty) 161 | let error = presence.Element Error |> Option.ofObj 162 | { From = from; Type = presenceType; States = states; Error = error } 163 | -------------------------------------------------------------------------------- /Emulsion/Xmpp/SharpXmppPingHandler.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Xmpp 6 | 7 | open SharpXMPP.XMPP.Client 8 | 9 | type SharpXmppPingHandler() = 10 | inherit PayloadHandler() 11 | 12 | override _.Handle(connection, element) = 13 | if SharpXmppHelper.isPing element then 14 | connection.Send(element.Reply()) 15 | true 16 | else 17 | false 18 | -------------------------------------------------------------------------------- /Emulsion/Xmpp/Types.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Xmpp 6 | 7 | open System 8 | open System.Xml.Linq 9 | 10 | open SharpXMPP.XMPP 11 | 12 | type Presence = { 13 | From: string 14 | States: int[] 15 | Error: XElement option 16 | Type: string option 17 | } 18 | 19 | type RoomInfo = { 20 | RoomJid: JID 21 | Nickname: string 22 | Password: string option 23 | Ping: {| Interval: TimeSpan option 24 | Timeout: TimeSpan |} 25 | } 26 | 27 | type MessageInfo = { 28 | RecipientJid: JID 29 | Text: string 30 | } 31 | 32 | type MessageDeliveryInfo = { 33 | MessageId: string 34 | 35 | /// Resolves after the message is guaranteed to be delivered to the recipient. 36 | Delivery: Async 37 | } 38 | -------------------------------------------------------------------------------- /Emulsion/Xmpp/XmppMessageSystem.fs: -------------------------------------------------------------------------------- 1 | // SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | // 3 | // SPDX-License-Identifier: MIT 4 | 5 | namespace Emulsion.Xmpp 6 | 7 | open System.Threading 8 | 9 | open JetBrains.Lifetimes 10 | 11 | open Emulsion.Messaging 12 | open Emulsion.Messaging.MessageSystem 13 | open Emulsion.Settings 14 | 15 | type XmppMessageSystem(ctx: ServiceContext, cancellationToken: CancellationToken, settings: XmppSettings) = 16 | inherit MessageSystemBase(ctx, cancellationToken) 17 | 18 | let mutable client = None 19 | 20 | member private _.BaseRunAsync r = base.RunAsync r 21 | 22 | override this.RunAsync receiver = async { 23 | // This overload essentially wraps a base method with a couple of "use" statements. 24 | use sharpXmpp = SharpXmppClient.create settings 25 | let newClient = SharpXmppClient.wrap sharpXmpp |> EmulsionXmpp.initializeLogging ctx.Logger 26 | use newClientLifetimeDef = Lifetime.Define() 27 | try 28 | Volatile.Write(&client, Some (newClient, newClientLifetimeDef.Lifetime)) 29 | do! this.BaseRunAsync receiver 30 | finally 31 | Volatile.Write(&client, None) 32 | } 33 | 34 | override _.RunUntilError receiver = async { 35 | match Volatile.Read &client with 36 | | Some(client, _) -> return! EmulsionXmpp.run settings ctx.Logger client receiver 37 | | None -> return failwith "The system cannot be run: the connection is not established" 38 | } 39 | 40 | override _.Send (OutgoingMessage message) = async { 41 | match Volatile.Read &client with 42 | | None -> failwith "Client is offline" 43 | | Some (client, lt) -> 44 | return! EmulsionXmpp.send ctx.Logger client lt settings message 45 | } 46 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | The MIT License 2 | =============== 3 | Copyright (C) 2025 Emulsion contributors 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /LICENSES/MIT.txt: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 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 | -------------------------------------------------------------------------------- /MAINTAINERSHIP.md: -------------------------------------------------------------------------------- 1 | 6 | 7 | Maintainership 8 | ============== 9 | 10 | Release 11 | ------- 12 | 13 | To release a new version: 14 | 1. Update the copyright year in the `LICENSE.md`, if required. 15 | 2. Choose a new version according to [Semantic Versioning][semver]. It should consist of three numbers (i.e. `1.0.0`). 16 | 3. Make sure there's a properly formed version entry in the `CHANGELOG.md`. 17 | 4. Update the `` property in the `Emulsion/Emulsion.fsproj` file. 18 | 5. Merge the aforementioned changes via a pull request. 19 | 6. Push a tag named `v` to GitHub. 20 | 21 | The new release will be published automatically. 22 | 23 | [semver]: https://semver.org/spec/v2.0.0.html 24 | -------------------------------------------------------------------------------- /NuGet.Config: -------------------------------------------------------------------------------- 1 | 2 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 6 | 7 | emulsion [![Docker Image][badge.docker]][docker-hub] [![Status Aquana][status-aquana]][andivionian-status-classifier] 8 | ======== 9 | 10 | emulsion is a bridge between [Telegram][telegram] and [XMPP][xmpp]. 11 | 12 | Installation 13 | ------------ 14 | There are two supported Emulsion distributions: as a framework-dependent .NET application, or as a Docker image. 15 | 16 | ### .NET Application 17 | To run Emulsion as [a framework-dependent .NET application][docs.dotnet.framework-dependent], you'll need to [install .NET runtime][dotnet] version 8.0 or later. 18 | 19 | Then, download the required version in the [Releases][releases] section. 20 | 21 | After that, configure the application (see the following section), and start it using the following shell command: 22 | 23 | ```console 24 | $ dotnet Emulsion.dll [optional-path-to-json-config-file] 25 | ``` 26 | 27 | If `optional-path-to-json-config-file` is not provided, Emulsion will use the `emulsion.json` file from the current directory. 28 | 29 | ### Docker 30 | It is recommended to use Docker to deploy this application. To install the application from Docker, you may use the following Bash script: 31 | 32 | ```bash 33 | NAME=emulsion 34 | EMULSION_VERSION=latest 35 | CONFIG=/opt/codingteam/emulsion/emulsion.json 36 | DATA=/opt/codingteam/emulsion/data # optional 37 | WEB_PORT=5051 # optional 38 | docker pull codingteam/emulsion:$EMULSION_VERSION 39 | docker rm -f $NAME 40 | docker run --name $NAME \ 41 | -v $CONFIG:/app/emulsion.json:ro \ 42 | -v $DATA:/data \ 43 | -p 127.0.0.1:$WEB_PORT:5000 \ 44 | --restart unless-stopped \ 45 | -d \ 46 | codingteam/emulsion:$EMULSION_VERSION 47 | ``` 48 | 49 | where 50 | 51 | - `$NAME` is the container name 52 | - `$EMULSION_VERSION` is the image version you want to deploy, or `latest` for 53 | the latest available one 54 | - `$CONFIG` is the **absolute** path to the configuration file 55 | - `$DATA` is the absolute path to the data directory (used by the configuration) 56 | - `$WEB_PORT` is the port on the host system which will be used to access the content proxy 57 | 58 | Configuration 59 | ------------- 60 | Copy `emulsion.example.json` to `emulsion.json` and set the settings. For some settings, there are defaults: 61 | 62 | ```json 63 | { 64 | "xmpp": { 65 | "roomPassword": null, 66 | "connectionTimeout": "00:05:00", 67 | "messageTimeout": "00:05:00", 68 | "pingInterval": null, 69 | "pingTimeout": "00:00:30" 70 | }, 71 | "fileCache": { 72 | "fileSizeLimitBytes": 1048576, 73 | "totalCacheSizeLimitBytes": 20971520 74 | }, 75 | "messageArchive": { 76 | "isEnabled": false 77 | } 78 | } 79 | ``` 80 | 81 | All the other settings are required, except the `database`, `hosting` and `fileCache` sections (the corresponding functionality will be turned off if the sections aren't filled). 82 | 83 | Note that `pingInterval` of `null` disables XMPP ping support. 84 | 85 | `telegram.messageThreadId` allows to connect the bot to a particular message thread: any messages from the other threads will be ignored, and the bot will send its messages to the selected thread only. 86 | 87 | `messageArchive.isEnabled` will enable or disable the message archive functionality. If enabled, the bot will save all the incoming messages to the database (so, `database` section from the next section is required for that to work). 88 | 89 | ### Telegram Content Proxy and Web Service 90 | 91 | There's Telegram content proxy support, for XMPP users to access Telegram content without directly opening links on t.me. 92 | 93 | To enable it, configure the `database`, `hosting` and `fileCache` configuration file sections: 94 | 95 | ```json 96 | { 97 | "database": { 98 | "dataSource": "sqliteDatabase.db" 99 | }, 100 | "hosting": { 101 | "externalUriBase": "https://example.com/api/", 102 | "bindUri": "http://*:5000/", 103 | "hashIdSalt": "test" 104 | }, 105 | "fileCache": { 106 | "directory": "/tmp/emulsion/cache", 107 | "fileSizeLimitBytes": 1048576, 108 | "totalCacheSizeLimitBytes": 20971520 109 | } 110 | } 111 | ``` 112 | 113 | `dataSource` may be a path to the SQLite database file on disk. If set, Emulsion will automatically apply necessary migrations to this database on startup. 114 | 115 | If all the parameters are set, then Emulsion will save the incoming messages into the database, and will then insert links to `{externalUriBase}/content/{contentId}` instead of links to `https://t.me/{messageId}`. 116 | 117 | `bindUri` designates the URI the web server will listen locally (which may or may not be the same as the `externalUriBase`). 118 | 119 | The content identifiers in question are generated from the database ones using the [hashids.net][hashids.net] library, `hashIdSalt` is used in generation. This should complicate guessing of content ids for any external party not reading the chat directly. 120 | 121 | If the `fileCache.directory` option is not set, then the content proxy will only generate redirects to corresponding t.me URIs. Otherwise, it will store the downloaded files (that fit the cache) in a cache on disk; the items not fitting into the cache will be proxied to clients. 122 | 123 | ### Recommended Network Configuration 124 | 125 | Current configuration system allows the following: 126 | 127 | 1. Set up a reverse proxy for, say, `https://example.com/telegram` taking the content from `http://localhost/`. 128 | 2. When receiving a piece of Telegram content (a file, a photo, an audio message), the bot will send a link to `https://example.com/telegram/content/` to the XMPP chat. 129 | 3. When anyone visits the link, the reverse proxy will send a request to `http://localhost/content/`, which will take a corresponding content from the database. 130 | 131 | Documentation 132 | ------------- 133 | - [Changelog][docs.changelog] 134 | - [Contributor Guide][docs.contributing] 135 | - [Maintainership][docs.maintainership] 136 | 137 | License 138 | ------- 139 | The project is distributed under the terms of [the MIT license][docs.license]. 140 | 141 | The license indication in the project's sources is compliant with the [REUSE specification v3.3][reuse.spec]. 142 | 143 | [andivionian-status-classifier]: https://github.com/ForNeVeR/andivionian-status-classifier#status-aquana- 144 | [badge.docker]: https://img.shields.io/docker/v/codingteam/emulsion?sort=semver 145 | [docker-hub]: https://hub.docker.com/r/codingteam/emulsion 146 | [docs.changelog]: ./CHANGELOG.md 147 | [docs.contributing]: CONTRIBUTING.md 148 | [docs.dotnet.framework-dependent]: https://learn.microsoft.com/en-us/dotnet/core/deploying/#publish-framework-dependent 149 | [docs.license]: ./LICENSE.md 150 | [docs.maintainership]: MAINTAINERSHIP.md 151 | [dotnet]: https://dot.net/ 152 | [hashids.net]: https://github.com/ullmark/hashids.net 153 | [releases]: https://github.com/codingteam/emulsion/releases 154 | [reuse.spec]: https://reuse.software/spec-3.3/ 155 | [status-aquana]: https://img.shields.io/badge/status-aquana-yellowgreen.svg 156 | [telegram]: https://telegram.org/ 157 | [xmpp]: https://xmpp.org/ 158 | -------------------------------------------------------------------------------- /emulsion.example.json: -------------------------------------------------------------------------------- 1 | { 2 | "xmpp": { 3 | "login": "hortomatic@example.org", 4 | "password": "my-super-password", 5 | "room": "xxxxx@conference.example.org", 6 | "roomPassword": "// optional", 7 | "nickname": "хортолёт", 8 | "connectionTimeout": "00:05:00", 9 | "messageTimeout": "00:05:00", 10 | "pingInterval": "00:01:00", 11 | "pingTimeout": "00:00:05" 12 | }, 13 | "telegram": { 14 | "token": "999999999:aaaaaaaaaaaaaaaaaaaaaaaaa_777777777", 15 | "groupId": 12312312312, 16 | "messageThreadId": 123456 17 | }, 18 | "log": { 19 | "directory": "./logs/" 20 | }, 21 | "database": { 22 | "dataSource": "sqliteDatabase.db" 23 | }, 24 | "hosting": { 25 | "externalUriBase": "https://example.com/api/", 26 | "bindUri": "http://*:5000", 27 | "hashIdSalt": "test" 28 | }, 29 | "fileCache": { 30 | "directory": "./cache", 31 | "fileSizeLimitBytes": 1048576, 32 | "totalCacheSizeLimitBytes": 20971520 33 | } 34 | } 35 | -------------------------------------------------------------------------------- /emulsion.example.json.license: -------------------------------------------------------------------------------- 1 | SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | 3 | SPDX-License-Identifier: MIT 4 | -------------------------------------------------------------------------------- /renovate.json: -------------------------------------------------------------------------------- 1 | { 2 | "$schema": "https://docs.renovatebot.com/renovate-schema.json", 3 | "extends": [ 4 | "config:recommended" 5 | ] 6 | } 7 | -------------------------------------------------------------------------------- /renovate.json.license: -------------------------------------------------------------------------------- 1 | SPDX-FileCopyrightText: 2024 Emulsion contributors 2 | 3 | SPDX-License-Identifier: MIT 4 | -------------------------------------------------------------------------------- /scripts/Get-Version.ps1: -------------------------------------------------------------------------------- 1 | # SPDX-FileCopyrightText: 2024 Friedrich von Never 2 | # 3 | # SPDX-License-Identifier: MIT 4 | 5 | param( 6 | [string] $RefName, 7 | [string] $RepositoryRoot = "$PSScriptRoot/..", 8 | 9 | $ProjectFile = "$RepositoryRoot/Emulsion/Emulsion.fsproj" 10 | ) 11 | 12 | $ErrorActionPreference = 'Stop' 13 | Set-StrictMode -Version Latest 14 | 15 | Write-Host "Determining version from ref `"$RefName`"…" 16 | if ($RefName -match '^refs/tags/v') { 17 | $version = $RefName -replace '^refs/tags/v', '' 18 | Write-Host "Pushed ref is a version tag, version: $version" 19 | } else { 20 | [xml] $props = Get-Content $ProjectFile 21 | $version = $props.Project.PropertyGroup.Version 22 | Write-Host "Pushed ref is a not version tag, get version from $($ProjectFile): $version" 23 | } 24 | 25 | Write-Output $version 26 | -------------------------------------------------------------------------------- /scripts/Test-Encoding.ps1: -------------------------------------------------------------------------------- 1 | # SPDX-FileCopyrightText: 2024 Friedrich von Never 2 | # 3 | # SPDX-License-Identifier: MIT 4 | 5 | <# 6 | .SYNOPSIS 7 | This script will verify that there's no UTF-8 BOM or CRLF line endings in the files inside of the project. 8 | #> 9 | param ( 10 | # Path to the repository root. All text files under the root will be checked for UTF-8 BOM and CRLF. 11 | $SourceRoot = "$PSScriptRoot/..", 12 | 13 | # Makes the script to perform file modifications to bring them to the standard. 14 | [switch] $Autofix 15 | ) 16 | 17 | Set-StrictMode -Version Latest 18 | $ErrorActionPreference = 'Stop' 19 | 20 | # For PowerShell to properly process the UTF-8 output from git ls-tree we need to set up the output encoding: 21 | [Console]::OutputEncoding = [Text.Encoding]::UTF8 22 | 23 | $allFiles = git -c core.quotepath=off ls-tree -r HEAD --name-only 24 | Write-Output "Total files in the repository: $($allFiles.Length)" 25 | 26 | # https://stackoverflow.com/questions/6119956/how-to-determine-if-git-handles-a-file-as-binary-or-as-text#comment15281840_6134127 27 | $nullHash = '4b825dc642cb6eb9a060e54bf8d69288fbee4904' 28 | $textFiles = git -c core.quotepath=off diff --numstat $nullHash HEAD -- @allFiles | 29 | Where-Object { -not $_.StartsWith('-') } | 30 | ForEach-Object { [Regex]::Unescape($_.Split("`t", 3)[2]) } 31 | Write-Output "Text files in the repository: $($textFiles.Length)" 32 | 33 | $bom = @(0xEF, 0xBB, 0xBF) 34 | $bomErrors = @() 35 | $lineEndingErrors = @() 36 | [array] $excludeExtensions = @('.dotsettings') 37 | 38 | try { 39 | Push-Location $SourceRoot 40 | foreach ($file in $textFiles) { 41 | if ($excludeExtensions -contains [IO.Path]::GetExtension($file).ToLowerInvariant()) { 42 | continue 43 | } 44 | 45 | $fullPath = Resolve-Path -LiteralPath $file 46 | $bytes = [IO.File]::ReadAllBytes($fullPath) | Select-Object -First $bom.Length 47 | $bytesEqualsBom = @(Compare-Object $bytes $bom -SyncWindow 0).Length -eq 0 48 | if ($bytesEqualsBom -and $Autofix) { 49 | $fullContent = [IO.File]::ReadAllBytes($fullPath) 50 | $newContent = $fullContent | Select-Object -Skip $bom.Length 51 | [IO.File]::WriteAllBytes($fullPath, $newContent) 52 | Write-Output "Removed UTF-8 BOM from file $file" 53 | } elseif ($bytesEqualsBom) { 54 | $bomErrors += @($file) 55 | } 56 | 57 | $text = [IO.File]::ReadAllText($fullPath) 58 | $hasWrongLineEndings = $text.Contains("`r`n") 59 | if ($hasWrongLineEndings -and $Autofix) { 60 | $newText = $text -replace "`r`n", "`n" 61 | [IO.File]::WriteAllText($fullPath, $newText) 62 | Write-Output "Fixed the line endings for file $file" 63 | } elseif ($hasWrongLineEndings) { 64 | $lineEndingErrors += @($file) 65 | } 66 | } 67 | 68 | if ($bomErrors.Length) { 69 | throw "The following $($bomErrors.Length) files have UTF-8 BOM:`n" + ($bomErrors -join "`n") 70 | } 71 | if ($lineEndingErrors.Length) { 72 | throw "The following $($lineEndingErrors.Length) files have CRLF instead of LF:`n" + ($lineEndingErrors -join "`n") 73 | } 74 | } finally { 75 | Pop-Location 76 | } 77 | --------------------------------------------------------------------------------