Activate synapse-cleanup
This commit is contained in:
parent
de6afc517b
commit
fd9985484b
|
@ -15,7 +15,7 @@ in {
|
||||||
../../roles/monitoring
|
../../roles/monitoring
|
||||||
../../roles/blog.nix
|
../../roles/blog.nix
|
||||||
../../roles/email2matrix.nix
|
../../roles/email2matrix.nix
|
||||||
../../roles/matrix-synapse.nix
|
../../roles/matrix-synapse
|
||||||
../../roles/coturn.nix
|
../../roles/coturn.nix
|
||||||
../../roles/go-neb.nix
|
../../roles/go-neb.nix
|
||||||
../../roles/laminar
|
../../roles/laminar
|
||||||
|
|
|
@ -3,6 +3,20 @@ let
|
||||||
server_name = "maralorn.de";
|
server_name = "maralorn.de";
|
||||||
hostName = "matrix.${server_name}";
|
hostName = "matrix.${server_name}";
|
||||||
in {
|
in {
|
||||||
|
systemd.services."matrix-cleanup" = {
|
||||||
|
serviceConfig = {
|
||||||
|
ExecStart = pkgs.writeHaskell "matrix-cleanup" {
|
||||||
|
libraries = builtins.attrValues pkgs.myHaskellScriptPackages ++ [
|
||||||
|
pkgs.haskellPackages.postgresql-simple
|
||||||
|
pkgs.haskellPackages.HTTP
|
||||||
|
];
|
||||||
|
ghcArgs = [ "-threaded" ];
|
||||||
|
} (builtins.readFile ./synapse-cleanup.hs);
|
||||||
|
User = "matrix-synapse";
|
||||||
|
Type = "oneshot";
|
||||||
|
};
|
||||||
|
startAt = "06:00";
|
||||||
|
};
|
||||||
services = {
|
services = {
|
||||||
nginx = {
|
nginx = {
|
||||||
enable = true;
|
enable = true;
|
||||||
|
@ -59,11 +73,18 @@ in {
|
||||||
dynamic_thumbnails = true;
|
dynamic_thumbnails = true;
|
||||||
turn_shared_secret = config.services.coturn.static-auth-secret;
|
turn_shared_secret = config.services.coturn.static-auth-secret;
|
||||||
turn_uris = let
|
turn_uris = let
|
||||||
turns =
|
turns = "turns:${config.services.coturn.realm}:${
|
||||||
"turns:${config.services.coturn.realm}:${toString config.services.coturn.tls-listening-port}";
|
toString config.services.coturn.tls-listening-port
|
||||||
turn =
|
}";
|
||||||
"turn:${config.services.coturn.realm}:${toString config.services.coturn.listening-port}";
|
turn = "turn:${config.services.coturn.realm}:${
|
||||||
in [ "${turns}?transport=udp" "${turns}?transport=tcp" "${turn}?transport=udp" "${turn}?transport=tcp" ];
|
toString config.services.coturn.listening-port
|
||||||
|
}";
|
||||||
|
in [
|
||||||
|
"${turns}?transport=udp"
|
||||||
|
"${turns}?transport=tcp"
|
||||||
|
"${turn}?transport=udp"
|
||||||
|
"${turn}?transport=tcp"
|
||||||
|
];
|
||||||
turn_user_lifetime = "24h";
|
turn_user_lifetime = "24h";
|
||||||
allow_guest_access = true;
|
allow_guest_access = true;
|
||||||
logConfig = ''
|
logConfig = ''
|
125
nixos/roles/matrix-synapse/synapse-cleanup.hs
Normal file
125
nixos/roles/matrix-synapse/synapse-cleanup.hs
Normal file
|
@ -0,0 +1,125 @@
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
|
{-# LANGUAGE TupleSections #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE ExtendedDefaultRules #-}
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE PartialTypeSignatures #-}
|
||||||
|
{-# OPTIONS_GHC -Wall -Wno-missing-signatures -Wno-type-defaults -Wno-orphans #-}
|
||||||
|
|
||||||
|
import Control.Concurrent
|
||||||
|
import Data.Aeson
|
||||||
|
import Data.String.Interpolate
|
||||||
|
import Data.Time
|
||||||
|
import Data.Time.Clock.POSIX
|
||||||
|
import Database.PostgreSQL.Simple
|
||||||
|
import Network.HTTP
|
||||||
|
import Prelude ( )
|
||||||
|
import Relude
|
||||||
|
import Say
|
||||||
|
import System.IO
|
||||||
|
|
||||||
|
newtype PurgeResult = PurgeResult
|
||||||
|
{ purge_id :: Text
|
||||||
|
}
|
||||||
|
deriving (Generic, FromJSON)
|
||||||
|
newtype Status = Status
|
||||||
|
{ status :: Text
|
||||||
|
}
|
||||||
|
deriving (Generic, FromJSON)
|
||||||
|
|
||||||
|
apiUrl :: Text
|
||||||
|
apiUrl = [i|http://localhost:8008/_synapse/admin/v1|]
|
||||||
|
daysOld = 30
|
||||||
|
lastMessages = 500
|
||||||
|
minUsersToPurgeRoom = 5
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = do
|
||||||
|
hSetBuffering stdout LineBuffering
|
||||||
|
upToTime <-
|
||||||
|
addUTCTime ((-1) * realToFrac daysOld * nominalDay) <$> getCurrentTime
|
||||||
|
conn <- connectPostgreSQL "dbname='matrix-synapse'"
|
||||||
|
(token :: Text) <-
|
||||||
|
fromMaybe (error "No admin token in database")
|
||||||
|
. viaNonEmpty head
|
||||||
|
<$> (fromOnly <<$>> query_
|
||||||
|
conn
|
||||||
|
"SELECT token FROM access_tokens JOIN users ON user_id=name WHERE admin=1 ORDER BY id DESC LIMIT 1"
|
||||||
|
)
|
||||||
|
let
|
||||||
|
upToTimeStamp = floor . (* 1000) . utcTimeToPOSIXSeconds $ upToTime
|
||||||
|
timeOutBody =
|
||||||
|
[i|{"delete_local_events":"true", "purge_up_to_ts":#{upToTimeStamp}}|]
|
||||||
|
contentType = "application/json"
|
||||||
|
setAuth = insertHeaders [Header HdrAuthorization [i|Bearer #{token}|]]
|
||||||
|
wait :: Text -> IO Text
|
||||||
|
wait purgeId = go 1
|
||||||
|
where
|
||||||
|
go timeout = do
|
||||||
|
say [i|purge #{purgeId} is going on waiting #{timeout} seconds|]
|
||||||
|
threadDelay (timeout * 1000000)
|
||||||
|
response <-
|
||||||
|
simpleHTTP
|
||||||
|
. setAuth
|
||||||
|
. getRequest
|
||||||
|
$ [i|#{apiUrl}/purge_history_status/#{purgeId}|]
|
||||||
|
case response of
|
||||||
|
Left _ -> pure "failed"
|
||||||
|
Right resp -> do
|
||||||
|
let res =
|
||||||
|
maybe "failed" status (decode . encodeUtf8 . rspBody $ resp)
|
||||||
|
if res == "active" then go (timeout * 2) else pure res
|
||||||
|
e <- simpleHTTP
|
||||||
|
. setAuth
|
||||||
|
. postRequest
|
||||||
|
$ [i|#{apiUrl}/purge_media_cache/?before_ts=#{upToTimeStamp}|]
|
||||||
|
sayShow e
|
||||||
|
roomIds <- fromOnly @Text <<$>> query
|
||||||
|
conn
|
||||||
|
"SELECT q.room_id FROM (select count(*) as numberofusers, room_id FROM current_state_events WHERE type ='m.room.member' GROUP BY room_id) AS q LEFT JOIN room_aliases a ON q.room_id=a.room_id WHERE q.numberofusers > ? ORDER BY numberofusers desc"
|
||||||
|
(Only minUsersToPurgeRoom)
|
||||||
|
forM_ roomIds $ \roomId -> do
|
||||||
|
eventId <-
|
||||||
|
fmap (second (posixSecondsToUTCTime . (/ 1000) . realToFrac))
|
||||||
|
. viaNonEmpty head
|
||||||
|
. mapMaybe sequence
|
||||||
|
<$> query
|
||||||
|
conn
|
||||||
|
"SELECT event_id, received_ts from events WHERE type='m.room.message' AND room_id =? ORDER BY received_ts DESC LIMIT 1 offset ?"
|
||||||
|
(roomId, lastMessages - 1)
|
||||||
|
let url = [i|#{apiUrl}/purge_history/#{roomId}|]
|
||||||
|
whenJust eventId $ \(name :: Text, timestamp) -> do
|
||||||
|
response <-
|
||||||
|
simpleHTTP
|
||||||
|
. setAuth
|
||||||
|
. postRequestWithBody url contentType
|
||||||
|
=<< if timestamp < upToTime
|
||||||
|
then
|
||||||
|
(do
|
||||||
|
say [i|Deleting up to #{name} in #{roomId}.|]
|
||||||
|
pure
|
||||||
|
[i|{"delete_local_events":"true", "purge_up_to_event_id":"#{name}"}|]
|
||||||
|
)
|
||||||
|
else do
|
||||||
|
say [i|Deleting up to last #{daysOld} days in #{roomId}.|]
|
||||||
|
pure timeOutBody
|
||||||
|
case response of
|
||||||
|
Left e ->
|
||||||
|
sayErr [i|Could not get purge status in #{roomId}. Error: #{e}|]
|
||||||
|
Right resp -> do
|
||||||
|
maybe
|
||||||
|
(sayErr [i|Could not parse purge result: #{rspBody resp}|])
|
||||||
|
(\purgeResult -> do
|
||||||
|
say
|
||||||
|
[i|Purging with id #{purge_id purgeResult} for room #{roomId}.|]
|
||||||
|
result <- wait (purge_id purgeResult)
|
||||||
|
say [i|Purge result: #{result}|]
|
||||||
|
)
|
||||||
|
(decode . encodeUtf8 . rspBody $ resp)
|
|
@ -14,7 +14,7 @@ let
|
||||||
brittany ormolu releaser cabal-fmt stack ghcid ghcide
|
brittany ormolu releaser cabal-fmt stack ghcid ghcide
|
||||||
haskell-language-server cabal-install dhall taskwarrior pandoc hlint
|
haskell-language-server cabal-install dhall taskwarrior pandoc hlint
|
||||||
cabal2nix weeder reflex-dom password optics shh-extras neuron
|
cabal2nix weeder reflex-dom password optics shh-extras neuron
|
||||||
hspec-discover cabal-edit paths hmatrix;
|
hspec-discover cabal-edit paths hmatrix postgresql-simple;
|
||||||
} // makeHaskellScriptPackages p;
|
} // makeHaskellScriptPackages p;
|
||||||
inherit (master) ghc haskellPackages;
|
inherit (master) ghc haskellPackages;
|
||||||
in {
|
in {
|
||||||
|
|
Loading…
Reference in a new issue