├── .github └── workflows │ └── ci.yml ├── .gitignore ├── .gitmodules ├── .snitch.yaml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── cabal.project ├── default.nix ├── kgbotka.cabal ├── secret.json.example ├── snapshot.yaml └── src ├── Client.hs ├── Control └── Monad │ └── Trans │ ├── Eval.hs │ └── Extra.hs ├── KGBotka ├── Asciify.hs ├── Bttv.hs ├── Calc.hs ├── Command.hs ├── Config.hs ├── DiscordLog.hs ├── DiscordThread.hs ├── Eval.hs ├── Expr.hs ├── Ffz.hs ├── Flip.hs ├── Friday.hs ├── GithubThread.hs ├── JoinedTwitchChannels.hs ├── Log.hs ├── Markov.hs ├── Migration.hs ├── Monitor.hs ├── Parser.hs ├── Queue.hs ├── Repl.hs ├── Roles.hs ├── Settings.hs ├── Sqlite.hs ├── TwitchAPI.hs ├── TwitchLog.hs ├── TwitchThread.hs └── Xkcd.hs ├── Main.hs └── MigrationTool.hs /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: [push, pull_request] 3 | 4 | # FIXME(#22): CI does not check formatting with hindent 5 | jobs: 6 | build-linux-ghc: 7 | runs-on: ubuntu-18.04 8 | steps: 9 | - uses: actions/checkout@v1 10 | with: 11 | submodules: 'recursive' 12 | - uses: actions/setup-haskell@v1 13 | with: 14 | ghc-version: '8.6.5' 15 | cabal-version: '3.0' 16 | - uses: actions/cache@v1 17 | with: 18 | path: ~/.cabal 19 | key: ${{ runner.os }}-haskell 20 | - name: install dependencies 21 | run: cabal v2-update 22 | - name: build 23 | run: cabal v2-build -f ci 24 | - name: lint 25 | run: curl -sL https://raw.github.com/ndmitchell/hlint/master/misc/travis.sh | sh -s ./src/ 26 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .ghc.environment* 2 | dist-newstyle/ 3 | dist/ 4 | *.json 5 | *.log 6 | *.db 7 | *.swp 8 | *.db-shm 9 | *.db-wal 10 | *.db.orig 11 | *~ 12 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "third_party/discord-haskell"] 2 | path = third_party/discord-haskell 3 | url = https://github.com/tsoding/discord-haskell 4 | [submodule "third_party/direct-sqlite"] 5 | path = third_party/direct-sqlite 6 | url = https://github.com/tsoding/direct-sqlite 7 | -------------------------------------------------------------------------------- /.snitch.yaml: -------------------------------------------------------------------------------- 1 | keywords: 2 | - TODO 3 | - FIXME 4 | title: 5 | transforms: 6 | - match: (.*) \-\-\> 7 | replace: $1 8 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for kgbotka 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2019 KGBotka Developer 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://github.com/tsoding/kgbotka/workflows/CI/badge.svg)](https://github.com/tsoding/kgbotka/actions) 2 | 3 | # KGBotka 4 | 5 | Twitch/Discord Chat Bot that works for KGB ![monkaS](https://cdn.betterttv.net/emote/56e9f494fff3cc5c35e5287e/1x) 6 | 7 | ## Quick Start 8 | 9 | **WARNING! CONTAINS SUBMODULES!** Clone with `git clone --recursive`. 10 | 11 | ### Cabal 12 | 13 | ```console 14 | $ cabal v2-build 15 | $ cabal v2-run kgbotka secret.json database.db 16 | ``` 17 | 18 | ### Stack 19 | 20 | ```console 21 | $ stack init --resolver=snapshot.yaml 22 | $ stack build 23 | $ stack run kgbotka secret.json database.db 24 | ``` 25 | 26 | ## secret.json 27 | 28 | See [./secret.json.example](./secret.json.example). 29 | 30 | ### Twitch 31 | 32 | The easiest way to obtain Twitch credentials right now is to 33 | 1. Go to https://tsoding.org/kgbotka-login/ 34 | 2. Press `Login` button and follow the instructions 35 | 3. Copy paste the generated credentials to your `secret.json`. 36 | Check [./secret.json.example](./secret.json.example) to learn about 37 | the format of the file. 38 | 39 | 40 | 41 | ### Discord 42 | 43 | See [OAuth2 for Bots](https://discord.com/developers/docs/topics/oauth2#bots) section of Discord documentation. 44 | 45 | ### GitHub 46 | 47 | 1. Generate the [Personal Access Token](https://github.com/settings/tokens) 48 | 2. Make sure you enable the `gist` scope, otherwise Friday Videos Gist synchronization won't work 49 | 50 | ## Features 51 | 52 | ### Friday Video Gist 53 | 54 | TBD 55 | 56 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./ 2 | ./third_party/discord-haskell/ 3 | ./third_party/direct-sqlite/ 4 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | with import {}; { 2 | kgbotkaEnv = stdenv.mkDerivation { 3 | name = "kgbotkaEnv"; 4 | buildInputs = [ ghc 5 | stack 6 | cabal-install 7 | openssl 8 | zlib 9 | haskellPackages.ghcid 10 | haskellPackages.hindent 11 | haskellPackages.hlint 12 | ]; 13 | LD_LIBRARY_PATH="${openssl.out}/lib;${zlib}/lib"; 14 | }; 15 | } 16 | -------------------------------------------------------------------------------- /kgbotka.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | 3 | -- Initial package description 'kgbotka.cabal' generated by 'cabal init'. 4 | -- For further documentation, see http://haskell.org/cabal/users-guide/ 5 | 6 | -- The name of the package. 7 | name: kgbotka 8 | 9 | -- The package version. See the Haskell package versioning policy (PVP) 10 | -- for standards guiding when and how versions should be incremented. 11 | -- https://pvp.haskell.org 12 | -- PVP summary: +-+------- breaking API changes 13 | -- | | +----- non-breaking API additions 14 | -- | | | +--- code changes with no API change 15 | version: 0.1.0.0 16 | 17 | -- A short (one-line) description of the package. 18 | synopsis: Bot that works for KGB 19 | 20 | -- A longer description of the package. 21 | -- description: 22 | 23 | -- URL for the project homepage or repository. 24 | homepage: https://github.com/tsoding/kgbotka 25 | 26 | -- A URL where users can report bugs. 27 | -- bug-reports: 28 | 29 | -- The license under which the package is released. 30 | license: MIT 31 | 32 | -- The file containing the license text. 33 | license-file: LICENSE 34 | 35 | -- The package author(s). 36 | author: me 37 | 38 | -- An email address to which users can send suggestions, bug reports, and 39 | -- patches. 40 | maintainer: reximkut@gmail.com 41 | 42 | -- A copyright notice. 43 | -- copyright: 44 | 45 | category: Control 46 | 47 | build-type: Simple 48 | 49 | -- Extra files to be distributed with the package, such as examples or a 50 | -- README. 51 | extra-source-files: CHANGELOG.md 52 | 53 | flag ci 54 | description: Enable strict checks for CI build 55 | default: False 56 | 57 | executable MigrationTool 58 | if flag(ci) 59 | ghc-options: -threaded -Wall -Werror 60 | else 61 | ghc-options: -threaded -Wall 62 | 63 | main-is: MigrationTool.hs 64 | 65 | other-modules: KGBotka.Migration 66 | , KGBotka.Command 67 | , KGBotka.TwitchAPI 68 | , KGBotka.Config 69 | , KGBotka.Roles 70 | 71 | build-depends: base >=4.12 && <4.13 72 | , bytestring >=0.10.8 && <0.11 73 | , sqlite-simple >=0.4.16 && <0.5 74 | , text >=1.2.4 && <1.3 75 | , time >=1.8.0 && <1.9 76 | , discord-haskell >= 1.6.0 && < 1.7.0 77 | , http-types >=0.12 && <0.13 78 | , http-client >=0.6.4 && <0.7 79 | , http-client-tls >=0.3.5 && <0.4 80 | , aeson >=1.4.6 && <1.5 81 | , irc-core >=2.7 && <2.8 82 | , directory >=1.3 && < 1.4 83 | , direct-sqlite ==2.3.26 84 | 85 | -- Directories containing source files. 86 | hs-source-dirs: src 87 | 88 | -- Base language which the package is written in. 89 | default-language: Haskell2010 90 | 91 | executable kgbotka-client 92 | if flag(ci) 93 | ghc-options: -threaded -Wall -Werror 94 | else 95 | ghc-options: -threaded -Wall 96 | 97 | main-is: Client.hs 98 | -- other-modules: 99 | 100 | build-depends: base >=4.12 && <4.13 101 | -- ghc 102 | , text >=1.2.4 && <1.3 103 | , network >=2.7 && <2.8 104 | , bytestring >=0.10.8 && <0.11 105 | , stm >=2.5 && <2.6 106 | 107 | -- Directories containing source files. 108 | hs-source-dirs: src 109 | 110 | -- Base language which the package is written in. 111 | default-language: Haskell2010 112 | 113 | executable kgbotka 114 | if flag(ci) 115 | ghc-options: -threaded -Wall -Werror 116 | else 117 | ghc-options: -threaded -Wall 118 | 119 | -- .hs or .lhs file containing the Main module. 120 | main-is: Main.hs 121 | 122 | -- Modules included in this executable, other than Main. 123 | other-modules: KGBotka.Migration 124 | , KGBotka.Calc 125 | , KGBotka.Command 126 | , KGBotka.Parser 127 | , KGBotka.Expr 128 | , KGBotka.Flip 129 | , KGBotka.Roles 130 | , KGBotka.TwitchAPI 131 | , KGBotka.TwitchThread 132 | , KGBotka.Queue 133 | , KGBotka.Repl 134 | , KGBotka.Config 135 | , KGBotka.Friday 136 | , KGBotka.TwitchLog 137 | , KGBotka.Markov 138 | , KGBotka.Asciify 139 | , KGBotka.Bttv 140 | , KGBotka.Ffz 141 | , KGBotka.Eval 142 | , KGBotka.Log 143 | , KGBotka.DiscordThread 144 | , KGBotka.DiscordLog 145 | , KGBotka.GithubThread 146 | , KGBotka.Settings 147 | , KGBotka.Sqlite 148 | , KGBotka.JoinedTwitchChannels 149 | , KGBotka.Xkcd 150 | , KGBotka.Monitor 151 | , Control.Monad.Trans.Extra 152 | , Control.Monad.Trans.Eval 153 | 154 | 155 | -- LANGUAGE extensions used by modules in this package. 156 | -- other-extensions: 157 | 158 | -- Other library packages from which modules are imported. 159 | build-depends: base >=4.12 && <4.13 160 | -- ghc 161 | , text >=1.2.4 && <1.3 162 | , stm >=2.5 && <2.6 163 | , containers >=0.6 && <0.7 164 | , transformers >=0.5.6.2 && <0.6 165 | , bytestring >=0.10.8 && <0.11 166 | , time >=1.8.0 && <1.9 167 | , array >=0.5.3 && <0.6 168 | -- hackage 169 | , aeson >=1.4.6 && <1.5 170 | , irc-core >=2.7 && <2.8 171 | , hookup >=0.3 && <0.4 172 | , network >=2.7 && <2.8 173 | , sqlite-simple >=0.4.16 && <0.5 174 | , network-uri >=2.6.1 && <2.7 175 | , http-types >=0.12 && <0.13 176 | , http-client >=0.6.4 && <0.7 177 | , http-client-tls >=0.3.5 && <0.4 178 | , regex-base >=0.94.0 && <0.95 179 | , regex-tdfa >=1.3.1 && <1.4 180 | , random >=1.1 && <1.2 181 | , louis==0.1.0.2 182 | , unordered-containers >=0.2.8.0 && <0.3 183 | , discord-haskell >= 1.6.0 && < 1.7.0 184 | , base64 >= 0.4 && < 0.5 185 | , direct-sqlite ==2.3.26 186 | , HsOpenSSL-x509-system == 0.1.0.4 187 | 188 | -- Directories containing source files. 189 | hs-source-dirs: src 190 | 191 | -- Base language which the package is written in. 192 | default-language: Haskell2010 193 | -------------------------------------------------------------------------------- /secret.json.example: -------------------------------------------------------------------------------- 1 | { 2 | "twitch": { 3 | "account": "", 4 | "token": "", 5 | "clientId": "" 6 | }, 7 | 8 | "discord": { 9 | "token": "" 10 | }, 11 | 12 | "github": { 13 | "token": "" 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /snapshot.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-14.27 2 | compiler: ghc-8.6.5 3 | 4 | packages: 5 | - discord-haskell-1.6.0 6 | - hookup-0.3.1.0 7 | - irc-core-2.7.2 8 | - louis-0.1.0.2 9 | - network-2.7.0.2 10 | - regex-base-0.94.0.0 11 | - regex-tdfa-1.3.1.0 12 | - text-1.2.4.0 13 | - emoji-0.1.0.2 14 | - base64-0.4.1 15 | - direct-sqlite-2.3.26 16 | - HsOpenSSL-x509-system-0.1.0.4 17 | -------------------------------------------------------------------------------- /src/Client.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent 4 | import Control.Concurrent.STM 5 | import qualified Control.Exception as E 6 | import qualified Data.ByteString.Char8 as C 7 | import Data.Functor 8 | import Network.Socket hiding (recv, send) 9 | import Network.Socket.ByteString (recv, send) 10 | import System.IO 11 | 12 | bufferSize :: Int 13 | bufferSize = 1024 14 | 15 | readThread :: TQueue C.ByteString -> Socket -> IO () 16 | readThread queue s = do 17 | chunk <- recv s bufferSize 18 | atomically $ writeTQueue queue chunk 19 | readThread queue s 20 | 21 | replState :: TQueue C.ByteString -> Socket -> IO () 22 | replState queue s = do 23 | threadDelay 10000 24 | chunks <- atomically $ flushTQueue queue 25 | putStr $ C.unpack $ C.concat chunks 26 | hFlush stdout 27 | line <- getLine 28 | void $ send s $ C.concat [C.pack line, C.pack "\n"] 29 | replState queue s 30 | 31 | csrfAuthState :: [C.ByteString] -> TQueue C.ByteString -> Socket -> IO () 32 | csrfAuthState chunks queue s = do 33 | chunks' <- atomically $ flushTQueue queue 34 | case C.lines (C.concat (chunks ++ chunks')) of 35 | [csrf, _] -> do 36 | void $ send s $ C.concat [C.drop 8 csrf, C.pack "\n"] 37 | putStrLn $ C.unpack $ C.drop 8 csrf 38 | putStrLn "Authorized!" 39 | replState queue s 40 | _ -> csrfAuthState (chunks ++ chunks') queue s 41 | 42 | -- TODO(#261): kgbotka-client does not detect closing the connection on the kgbotka side 43 | main :: IO () 44 | main = 45 | runTCPClient "127.0.0.1" "6969" $ \s -> do 46 | putStrLn "Connected!" 47 | queue <- atomically newTQueue 48 | void $ forkIO $ readThread queue s 49 | csrfAuthState [] queue s 50 | 51 | runTCPClient :: HostName -> ServiceName -> (Socket -> IO a) -> IO a 52 | runTCPClient host port client = 53 | withSocketsDo $ do 54 | addr <- resolve 55 | E.bracket (open addr) close client 56 | where 57 | resolve = do 58 | let hints = defaultHints {addrSocketType = Stream} 59 | head <$> getAddrInfo (Just hints) (Just host) (Just port) 60 | open addr = do 61 | sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 62 | connect sock $ addrAddress addr 63 | return sock 64 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | 4 | module Control.Monad.Trans.Eval where 5 | 6 | import Control.Applicative 7 | import Control.Monad.IO.Class 8 | import Control.Monad.Trans.Class 9 | import Control.Monad.Trans.Except 10 | import Control.Monad.Trans.State.Strict 11 | 12 | newtype EvalT s e m a = EvalT 13 | { runEvalT :: StateT s (ExceptT e m) a 14 | } deriving (Functor) 15 | 16 | instance Monad m => Applicative (EvalT s e m) where 17 | pure = EvalT . pure 18 | (EvalT f) <*> (EvalT s) = EvalT (f <*> s) 19 | 20 | instance Monad m => Monad (EvalT s e m) where 21 | (EvalT s) >>= f = EvalT (s >>= g) 22 | where 23 | g (f -> EvalT x) = x 24 | 25 | instance MonadTrans (EvalT s e) where 26 | lift = EvalT . lift . lift 27 | 28 | instance MonadIO m => MonadIO (EvalT s e m) where 29 | liftIO = EvalT . liftIO 30 | 31 | instance (Monoid e, Monad m) => Alternative (EvalT s e m) where 32 | empty = EvalT empty 33 | EvalT s1 <|> EvalT s2 = EvalT (s1 <|> s2) 34 | 35 | exceptEval :: Monad m => Either e a -> EvalT s e m a 36 | exceptEval = EvalT . lift . except 37 | 38 | liftExceptT :: Monad m => ExceptT e m a -> EvalT s e m a 39 | liftExceptT = EvalT . lift 40 | 41 | getEval :: Monad m => EvalT s e m s 42 | getEval = EvalT get 43 | 44 | modifyEval :: Monad m => (s -> s) -> EvalT s e m () 45 | modifyEval = EvalT . modify 46 | 47 | throwExceptEval :: Monad m => e -> EvalT s e m a 48 | throwExceptEval = EvalT . lift . throwE 49 | -------------------------------------------------------------------------------- /src/Control/Monad/Trans/Extra.hs: -------------------------------------------------------------------------------- 1 | module Control.Monad.Trans.Extra where 2 | 3 | import Control.Monad.Trans.Maybe 4 | 5 | hoistMaybe :: Monad m => Maybe a -> MaybeT m a 6 | hoistMaybe = MaybeT . return 7 | -------------------------------------------------------------------------------- /src/KGBotka/Asciify.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module KGBotka.Asciify 5 | ( asciifyUrl 6 | ) where 7 | 8 | import Control.Applicative 9 | import Control.Monad.Trans.Class 10 | import Control.Monad.Trans.Except 11 | import Control.Monad.Trans.Maybe 12 | import qualified Data.ByteString.Lazy as BS 13 | import Data.Maybe 14 | import qualified Data.Text as T 15 | import Database.SQLite.Simple 16 | import Database.SQLite.Simple.QQ 17 | import Louis 18 | import qualified Network.HTTP.Client as HTTP 19 | 20 | fromCache :: Connection -> T.Text -> MaybeT IO T.Text 21 | fromCache dbConn url = 22 | MaybeT 23 | (fmap fromOnly . listToMaybe <$> 24 | queryNamed 25 | dbConn 26 | [sql|SELECT image FROM AsciifyUrlCache WHERE url = :url|] 27 | [":url" := url]) 28 | 29 | fromUrl :: HTTP.Manager -> T.Text -> ExceptT String IO T.Text 30 | fromUrl manager url = do 31 | request <- HTTP.parseRequest $ T.unpack url 32 | response <- lift $ HTTP.httpLbs request manager 33 | fmap T.unwords $ 34 | except $ braillizeByteString $ BS.toStrict $ HTTP.responseBody response 35 | 36 | cacheImage :: Connection -> T.Text -> T.Text -> IO () 37 | cacheImage dbConn url image = 38 | executeNamed 39 | dbConn 40 | [sql|INSERT INTO AsciifyUrlCache (url, image) VALUES (:url, :image)|] 41 | [":url" := url, ":image" := image] 42 | 43 | asciifyUrl :: Connection -> HTTP.Manager -> T.Text -> ExceptT String IO T.Text 44 | asciifyUrl dbConn manager url 45 | -- NOTE: `Nothing` from `fromCache` indicates the cache miss. We set 46 | -- the error to empty string because `ExceptT` expects exceptions to 47 | -- be `Monoid`s and simply `mappend`s them together. So by setting 48 | -- error of `fromCache` to empty string we don't disturb the error 49 | -- of `fromUrl` and `cacheImage` 50 | = 51 | maybeToExceptT "" (fromCache dbConn url) <|> do 52 | image <- fromUrl manager url 53 | lift $ cacheImage dbConn url image 54 | return image 55 | -------------------------------------------------------------------------------- /src/KGBotka/Bttv.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | module KGBotka.Bttv 6 | ( updateBttvEmotes 7 | , getBttvEmoteByName 8 | , BttvEmote(..) 9 | ) where 10 | 11 | import Control.Monad.Trans.Class 12 | import Control.Monad.Trans.Except 13 | import Control.Monad.Trans.Maybe 14 | import Data.Aeson 15 | import Data.Aeson.Types 16 | import Data.Foldable 17 | import Data.Maybe 18 | import qualified Data.Text as T 19 | import Database.SQLite.Simple 20 | import Database.SQLite.Simple.QQ 21 | import Irc.Identifier (idText) 22 | import KGBotka.TwitchAPI 23 | import Network.HTTP.Client 24 | import Network.URI 25 | 26 | data BttvEmote = BttvEmote 27 | { bttvEmoteName :: T.Text 28 | , bttvEmoteImageUrl :: T.Text 29 | , bttvEmoteChannel :: Maybe TwitchIrcChannel 30 | } 31 | 32 | instance FromRow BttvEmote where 33 | fromRow = BttvEmote <$> field <*> field <*> field 34 | 35 | updateBttvEmoteChannel :: Maybe TwitchIrcChannel -> BttvEmote -> BttvEmote 36 | updateBttvEmoteChannel channel bttvEmote = 37 | bttvEmote {bttvEmoteChannel = channel} 38 | 39 | newtype BttvRes = BttvRes 40 | { bttvResEmotes :: [BttvEmote] 41 | } 42 | 43 | instance FromJSON BttvRes where 44 | parseJSON (Object v) = BttvRes <$> v .: "emotes" 45 | parseJSON invalid = typeMismatch "BttvRes" invalid 46 | 47 | -- @uri 48 | instance FromJSON BttvEmote where 49 | parseJSON (Object v) = BttvEmote <$> code <*> url <*> return Nothing 50 | where 51 | code = v .: "code" 52 | url = 53 | (\id' -> "https://cdn.betterttv.net/emote/" <> id' <> "/3x") <$> 54 | (v .: "id") 55 | parseJSON invalid = typeMismatch "BttvEmote" invalid 56 | 57 | queryBttvEmotes :: 58 | Manager -> Maybe TwitchIrcChannel -> ExceptT String IO [BttvEmote] 59 | queryBttvEmotes manager Nothing 60 | -- @uri 61 | = do 62 | request <- parseRequest "https://api.betterttv.net/2/emotes" 63 | response <- lift (responseBody <$> httpLbs request manager) 64 | let jsonResponse = eitherDecode response 65 | except (bttvResEmotes <$> jsonResponse) 66 | queryBttvEmotes manager channel'@(Just (TwitchIrcChannel (idText -> channel))) = 67 | case T.uncons channel of 68 | Just ('#', channelName) -> do 69 | let encodeURI = escapeURIString (const False) 70 | -- @uri 71 | request <- 72 | parseRequest $ 73 | "https://api.betterttv.net/2/channels/" <> 74 | encodeURI (T.unpack channelName) 75 | response <- lift (responseBody <$> httpLbs request manager) 76 | let jsonResponse = eitherDecode response 77 | except $ 78 | map (updateBttvEmoteChannel channel') . bttvResEmotes <$> jsonResponse 79 | _ -> 80 | let invalidChannelName = channel 81 | in throwE $ 82 | "Channel name " <> T.unpack invalidChannelName <> 83 | " does not start with #" 84 | 85 | -- TODO(#242): updateBttvEmotes does not handle channels that do no exist on BTTV 86 | updateBttvEmotes :: 87 | Connection -> Manager -> Maybe TwitchIrcChannel -> ExceptT String IO () 88 | updateBttvEmotes dbConn manager channel = do 89 | lift $ 90 | executeNamed 91 | dbConn 92 | [sql|DELETE FROM BttvEmotes WHERE channel IS :channel;|] 93 | [":channel" := channel] 94 | bttvEmotes <- queryBttvEmotes manager channel 95 | for_ bttvEmotes $ \emote -> 96 | lift $ 97 | executeNamed 98 | dbConn 99 | [sql|INSERT INTO BttvEmotes (name, imageUrl, channel) 100 | VALUES (:name, :imageUrl, :channel)|] 101 | [ ":name" := bttvEmoteName emote 102 | , ":imageUrl" := bttvEmoteImageUrl emote 103 | , ":channel" := bttvEmoteChannel emote 104 | ] 105 | 106 | getBttvEmoteByName :: 107 | Connection -> T.Text -> Maybe TwitchIrcChannel -> MaybeT IO BttvEmote 108 | getBttvEmoteByName dbConn name channel = 109 | MaybeT 110 | (listToMaybe <$> 111 | queryNamed 112 | dbConn 113 | [sql|SELECT name, imageUrl, channel FROM BttvEmotes 114 | WHERE (channel is :channel OR channel is NULL) 115 | AND name is :name|] 116 | [":channel" := channel, ":name" := name]) 117 | -------------------------------------------------------------------------------- /src/KGBotka/Calc.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module KGBotka.Calc where 5 | 6 | import Control.Applicative (Alternative(..)) 7 | import Control.Monad (void) 8 | import Control.Monad.Trans.Class (lift) 9 | import Control.Monad.Trans.Except (ExceptT(..), throwE) 10 | import Data.Char (isAlpha, isDigit) 11 | import qualified Data.Map.Strict as M 12 | import qualified Data.Text as T 13 | import KGBotka.Parser 14 | import System.Random (randomIO) 15 | 16 | data Operator 17 | = Add 18 | | Sub 19 | | Mul 20 | | Div 21 | | Mod 22 | | Pow 23 | deriving (Show, Eq) 24 | 25 | data CalcExpression 26 | = BinaryExpression Operator 27 | CalcExpression 28 | CalcExpression 29 | | NegativeExpression CalcExpression 30 | | FunctionApplication T.Text 31 | [CalcExpression] 32 | | ValueExpression Double 33 | deriving (Show) 34 | 35 | newtype CalcEvalError = 36 | CalcEvalError T.Text 37 | deriving (Show) 38 | 39 | type CalcEval = ExceptT CalcEvalError IO 40 | 41 | parseNumber :: Parser Double 42 | parseNumber = parseFloating <|> parseInteger 43 | where 44 | parseNumeric :: Parser T.Text 45 | parseNumeric = notNull "Expected a numeric value" $ takeWhileP isDigit 46 | parseInteger :: Parser Double 47 | parseInteger = read . T.unpack <$> parseNumeric 48 | -- TODO(#177): parseFloating does not support exponential number format 49 | parseFloating :: Parser Double 50 | parseFloating = do 51 | integerPart <- parseNumeric 52 | void $ charP '.' 53 | fractionalPart <- parseNumeric 54 | return $ read $ T.unpack $ integerPart <> "." <> fractionalPart 55 | 56 | parseLine :: Parser CalcExpression 57 | parseLine = parseExpression <* eof 58 | 59 | parseExpression :: Parser CalcExpression 60 | parseExpression = parseAdditive 61 | 62 | parseAdditive :: Parser CalcExpression 63 | parseAdditive = parseAdditive' <|> parseMultiplicative 64 | where 65 | parseAdditive' = do 66 | left <- parseMultiplicative 67 | operator <- (Add <$ charP '+') <|> (Sub <$ charP '-') 68 | BinaryExpression operator left <$> parseAdditive 69 | 70 | parseMultiplicative :: Parser CalcExpression 71 | parseMultiplicative = parseMultiplicative' <|> parseExponentiation 72 | where 73 | parseMultiplicative' = do 74 | left <- parseExponentiation 75 | operator <- 76 | (Mul <$ charP '*') <|> (Div <$ charP '/') <|> (Mod <$ charP '%') 77 | BinaryExpression operator left <$> parseMultiplicative 78 | 79 | parseExponentiation :: Parser CalcExpression 80 | parseExponentiation = parseExponentiation' <|> parseAtom 81 | where 82 | parseExponentiation' = do 83 | left <- parseNegation 84 | operator <- Pow <$ charP '^' 85 | BinaryExpression operator left <$> parseExponentiation 86 | 87 | parseNegation :: Parser CalcExpression 88 | parseNegation = parseNegation' <|> parseAtom 89 | where 90 | parseNegation' = do 91 | void $ charP '-' 92 | NegativeExpression <$> parseNegation 93 | 94 | parseFunctionApplication :: Parser CalcExpression 95 | parseFunctionApplication = do 96 | functionName <- notNull "Expected a function name" $ takeWhileP isAlpha 97 | FunctionApplication functionName <$> 98 | inParens (sepBy parseExpression (charP ',' <* ws) <|> return []) 99 | 100 | -- TODO(#178): Make calc variables a seperate constructor of CalcExpression 101 | parseVariable :: Parser CalcExpression 102 | parseVariable = do 103 | varName <- notNull "Expected a variable name" $ takeWhileP isAlpha 104 | return $ FunctionApplication varName [] 105 | 106 | parseValue :: Parser CalcExpression 107 | parseValue = ValueExpression <$> parseNumber 108 | 109 | parseAtom :: Parser CalcExpression 110 | parseAtom = 111 | ws *> 112 | (parseValue <|> parseFunctionApplication <|> parseVariable <|> 113 | inParens parseExpression) <* 114 | ws 115 | 116 | evalCalcExpression :: CalcExpression -> CalcEval Double 117 | evalCalcExpression (BinaryExpression op left right) = do 118 | left' <- evalCalcExpression left 119 | right' <- evalCalcExpression right 120 | return $ 121 | (case op of 122 | Add -> (+) 123 | Sub -> (-) 124 | Mul -> (*) 125 | Div -> (/) 126 | Mod -> 127 | \a b -> 128 | fromIntegral $ 129 | mod (toInteger (floor a :: Integer)) (toInteger (floor b :: Integer)) 130 | Pow -> (**)) 131 | left' 132 | right' 133 | evalCalcExpression (NegativeExpression body) = 134 | (* (-1.0)) <$> evalCalcExpression body 135 | evalCalcExpression (ValueExpression val) = return val 136 | evalCalcExpression (FunctionApplication functionName args) = 137 | case M.lookup functionName functionLookupTable of 138 | Just f -> mapM evalCalcExpression args >>= f 139 | Nothing -> throwE $ CalcEvalError "undefined is not a function FeelsDankMan" 140 | 141 | functionLookupTable :: M.Map T.Text ([Double] -> CalcEval Double) 142 | functionLookupTable = 143 | M.fromList 144 | [ ( "pi" 145 | , \case 146 | [] -> return pi 147 | _ -> throwE $ CalcEvalError "pi is not a function") 148 | , ( "e" 149 | , \case 150 | [] -> return $ exp 1 151 | _ -> throwE $ CalcEvalError "e is not a function") 152 | , ( "sin" 153 | , \case 154 | [x] -> return $ sin x 155 | _ -> throwE $ CalcEvalError "sin expects one argument") 156 | , ( "cos" 157 | , \case 158 | [x] -> return $ cos x 159 | _ -> throwE $ CalcEvalError "cos expects one argument") 160 | , ( "tan" 161 | , \case 162 | [x] -> return $ tan x 163 | _ -> throwE $ CalcEvalError "tan expects one argument") 164 | , ( "arcsin" 165 | , \case 166 | [x] -> return $ asin x 167 | _ -> throwE $ CalcEvalError "arcsin expects one argument") 168 | , ( "arccos" 169 | , \case 170 | [x] -> return $ acos x 171 | _ -> throwE $ CalcEvalError "arccos expects one argument") 172 | , ( "arctan" 173 | , \case 174 | [x] -> return $ atan x 175 | _ -> throwE $ CalcEvalError "arctan expects one argument") 176 | , ( "exp" 177 | , \case 178 | [x] -> return $ exp x 179 | _ -> throwE $ CalcEvalError "exp expects one argument") 180 | , ( "ln" 181 | , \case 182 | [x] -> return $ log x 183 | _ -> throwE $ CalcEvalError "ln expects one argument") 184 | , ( "nthroot" 185 | , \case 186 | [n, x] -> return $ x ** recip n 187 | _ -> 188 | throwE $ 189 | CalcEvalError "nthroot expects two arguments (radix and radicand)") 190 | , ( "sqrt" 191 | , \case 192 | [x] -> return $ sqrt x 193 | _ -> throwE $ CalcEvalError "sqrt expects one argument") 194 | , ( "random" 195 | , \case 196 | [] -> lift randomIO 197 | _ -> throwE $ CalcEvalError "random takes no arguments") 198 | ] 199 | -------------------------------------------------------------------------------- /src/KGBotka/Command.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | module KGBotka.Command 6 | ( CommandCall(..) 7 | , parseCommandPipe 8 | , Command(..) 9 | , commandByName 10 | , addCommand 11 | , addCommandName 12 | , deleteCommandByName 13 | , deleteCommandName 14 | , ccArgsModify 15 | , logCommand 16 | , isCommandCooleddown 17 | , CallPrefix(..) 18 | , PipeSuffix(..) 19 | , DiscordUserId(..) 20 | , bumpCommandTimes 21 | ) where 22 | 23 | import Data.Char 24 | import Data.Int 25 | import Data.Maybe 26 | import qualified Data.Text as T 27 | import Data.Time 28 | import Data.Word 29 | import Database.SQLite.Simple 30 | import Database.SQLite.Simple.QQ 31 | import Database.SQLite.Simple.ToField 32 | import Discord.Types 33 | import KGBotka.TwitchAPI 34 | 35 | data Command = Command 36 | { commandId :: Int 37 | , commandCode :: T.Text 38 | , commandUserCooldown :: Int 39 | , commandTimes :: Int 40 | , commandArgsRegex :: T.Text 41 | } 42 | 43 | data CommandLog = CommandLog 44 | { commandLogUserTwitchId :: TwitchUserId 45 | , commandLogCommandId :: Int 46 | , commandLogCommandArgs :: T.Text 47 | , commnadLogTimestamp :: UTCTime 48 | } deriving (Show) 49 | 50 | logCommand :: 51 | Connection 52 | -> Maybe DiscordUserId 53 | -> Maybe TwitchUserId 54 | -> Int 55 | -> T.Text 56 | -> IO () 57 | logCommand dbConn userDiscordId userTwitchId commandIdent commandArgs = 58 | executeNamed 59 | dbConn 60 | [sql|INSERT INTO CommandLog (userDiscordId, userTwitchId, commandId, commandArgs) 61 | VALUES (:userDiscordId, :userTwitchId, :commandId, :commandArgs)|] 62 | [ ":userDiscordId" := userDiscordId 63 | , ":userTwitchId" := userTwitchId 64 | , ":commandId" := commandIdent 65 | , ":commandArgs" := commandArgs 66 | ] 67 | 68 | instance FromRow Command where 69 | fromRow = Command <$> field <*> field <*> field <*> field <*> field 70 | 71 | commandByName :: Connection -> T.Text -> IO (Maybe Command) 72 | commandByName conn name = 73 | listToMaybe <$> queryNamed conn queryText [":commandName" := name] 74 | where 75 | queryText = 76 | [sql|SELECT c.id, c.code, c.user_cooldown_ms, c.times, c.argsRegex 77 | FROM Command c 78 | INNER JOIN CommandName cn ON c.id = cn.commandId 79 | WHERE cn.name = :commandName;|] 80 | 81 | addCommand :: Connection -> T.Text -> T.Text -> IO Int64 82 | addCommand dbConn name code = do 83 | executeNamed 84 | dbConn 85 | [sql|INSERT INTO Command (code) VALUES (:commandCode)|] 86 | [":commandCode" := code] 87 | ident <- lastInsertRowId dbConn 88 | executeNamed 89 | dbConn 90 | [sql|INSERT INTO CommandName (name, commandId) 91 | VALUES (:commandName, :commandId)|] 92 | [":commandName" := name, ":commandId" := ident] 93 | return ident 94 | 95 | deleteCommandById :: Connection -> Int -> IO () 96 | deleteCommandById dbConn ident = 97 | executeNamed 98 | dbConn 99 | [sql|DELETE FROM Command WHERE id = :commandId|] 100 | [":commandId" := ident] 101 | 102 | bumpCommandTimes :: Connection -> Int -> IO () 103 | bumpCommandTimes dbConn ident = 104 | executeNamed 105 | dbConn 106 | [sql|UPDATE Command SET times = times + 1 WHERE id = :commandId|] 107 | [":commandId" := ident] 108 | 109 | deleteCommandByName :: Connection -> T.Text -> IO () 110 | deleteCommandByName dbConn name = 111 | commandByName dbConn name >>= 112 | maybe (return ()) (deleteCommandById dbConn . commandId) 113 | 114 | deleteCommandName :: Connection -> T.Text -> IO () 115 | deleteCommandName dbConn name = 116 | executeNamed 117 | dbConn 118 | [sql|DELETE FROM CommandName WHERE name = :commandName|] 119 | [":commandName" := name] 120 | 121 | addCommandName :: Connection -> T.Text -> T.Text -> IO () 122 | addCommandName dbConn alias name = do 123 | command <- commandByName dbConn name 124 | case command of 125 | Just Command {commandId = ident} -> 126 | executeNamed 127 | dbConn 128 | [sql|INSERT INTO CommandName (name, commandId) 129 | VALUES (:commandName, :commandId)|] 130 | [":commandName" := alias, ":commandId" := ident] 131 | Nothing -> return () 132 | 133 | data CommandCall = CommandCall 134 | { ccName :: T.Text 135 | , ccArgs :: T.Text 136 | } deriving (Eq, Show) 137 | 138 | newtype CallPrefix = 139 | CallPrefix T.Text 140 | deriving (Show) 141 | 142 | newtype PipeSuffix = 143 | PipeSuffix T.Text 144 | 145 | parseCommandPipe :: CallPrefix -> PipeSuffix -> T.Text -> [CommandCall] 146 | parseCommandPipe callPrefix (PipeSuffix pipeSuffix) source = 147 | fromMaybe [] $ 148 | mapM (parseCommandCall callPrefix) $ T.splitOn pipeSuffix source 149 | 150 | parseCommandCall :: CallPrefix -> T.Text -> Maybe CommandCall 151 | parseCommandCall (CallPrefix prefix) source = 152 | uncurry CommandCall . fmap T.strip . T.span isAlphaNum <$> 153 | T.stripPrefix prefix (T.dropWhile isSpace source) 154 | 155 | ccArgsModify :: (T.Text -> T.Text) -> CommandCall -> CommandCall 156 | ccArgsModify f cc = cc {ccArgs = f $ ccArgs cc} 157 | 158 | newtype DiscordUserId = 159 | DiscordUserId Snowflake 160 | 161 | instance ToField DiscordUserId where 162 | toField (DiscordUserId userDiscordId) = 163 | toField (fromIntegral userDiscordId :: Word64) 164 | 165 | isCommandCooleddown :: 166 | Connection -> Maybe DiscordUserId -> Maybe TwitchUserId -> Int -> IO Bool 167 | isCommandCooleddown dbConn userDiscordId userTwitchId commandIdent = do 168 | x <- 169 | listToMaybe <$> 170 | queryNamed 171 | dbConn 172 | [sql|SELECT cl.timestamp, c.user_cooldown_ms 173 | FROM CommandLog cl 174 | JOIN Command c ON c.id = cl.commandId 175 | WHERE cl.userTwitchId is :userTwitchId 176 | AND cl.userDiscordId is :userDiscordId 177 | AND cl.commandId = :commandIdent 178 | ORDER BY cl.timestamp DESC 179 | LIMIT 1; |] 180 | [ ":userTwitchId" := userTwitchId 181 | , ":commandIdent" := commandIdent 182 | , ":userDiscordId" := userDiscordId 183 | ] 184 | case x of 185 | Just (timestamp, cooldownMs) -> do 186 | now <- getCurrentTime 187 | let diffSec = realToFrac (diffUTCTime now timestamp) :: Double 188 | let cooldownSec = fromIntegral (cooldownMs :: Integer) / 1000.0 189 | return $ diffSec > cooldownSec 190 | Nothing -> return True 191 | -------------------------------------------------------------------------------- /src/KGBotka/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module KGBotka.Config where 4 | 5 | import Data.Aeson 6 | import Data.Aeson.Types 7 | import qualified Data.Text as T 8 | 9 | data Config = Config 10 | { configTwitch :: !(Maybe ConfigTwitch) 11 | , configDiscord :: !(Maybe ConfigDiscord) 12 | , configGithub :: !(Maybe ConfigGithub) 13 | } deriving (Eq) 14 | 15 | newtype GithubToken = GithubToken 16 | { githubTokenText :: T.Text 17 | } deriving (Eq) 18 | 19 | instance FromJSON GithubToken where 20 | parseJSON v = GithubToken <$> parseJSON v 21 | 22 | newtype ConfigGithub = ConfigGithub 23 | { configGithubToken :: GithubToken 24 | } deriving (Eq) 25 | 26 | data ConfigTwitch = ConfigTwitch 27 | { configTwitchAccount :: !T.Text 28 | , configTwitchToken :: !T.Text 29 | , configTwitchClientId :: !T.Text 30 | } deriving (Eq) 31 | 32 | newtype ConfigDiscord = ConfigDiscord 33 | { configDiscordToken :: T.Text 34 | } deriving (Eq) 35 | 36 | instance FromJSON Config where 37 | parseJSON (Object v) = 38 | Config <$> v .:? "twitch" <*> v .:? "discord" <*> v .:? "github" 39 | parseJSON invalid = typeMismatch "Config" invalid 40 | 41 | instance FromJSON ConfigTwitch where 42 | parseJSON (Object v) = 43 | ConfigTwitch <$> v .: "account" <*> v .: "token" <*> v .: "clientId" 44 | parseJSON invalid = typeMismatch "ConfigTwitch" invalid 45 | 46 | instance FromJSON ConfigDiscord where 47 | parseJSON (Object v) = ConfigDiscord <$> v .: "token" 48 | parseJSON invalid = typeMismatch "ConfigDiscord" invalid 49 | 50 | instance FromJSON ConfigGithub where 51 | parseJSON (Object v) = ConfigGithub <$> v .: "token" 52 | parseJSON invalid = typeMismatch "ConfigGithub" invalid 53 | -------------------------------------------------------------------------------- /src/KGBotka/DiscordLog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module KGBotka.DiscordLog where 5 | 6 | import qualified Data.Text as T 7 | import Database.SQLite.Simple 8 | import Database.SQLite.Simple.QQ 9 | import Discord.Types 10 | 11 | logMessage :: 12 | Connection 13 | -> Maybe GuildId 14 | -> ChannelId 15 | -> UserId 16 | -> T.Text 17 | -> T.Text 18 | -> IO () 19 | logMessage dbConn guild channel user displayName message = 20 | executeNamed 21 | dbConn 22 | [sql|INSERT INTO DiscordLog ( 23 | guildId, 24 | channelId, 25 | senderDiscordId, 26 | senderDiscordDisplayName, 27 | message 28 | ) VALUES ( 29 | :guildId, 30 | :channelId, 31 | :senderDiscordId, 32 | :senderDiscordDisplayName, 33 | :message 34 | ) |] 35 | [ ":guildId" := T.pack (show guild) 36 | , ":channelId" := T.pack (show channel) 37 | , ":senderDiscordId" := T.pack (show user) 38 | , ":senderDiscordDisplayName" := displayName 39 | , ":message" := message 40 | ] 41 | -------------------------------------------------------------------------------- /src/KGBotka/DiscordThread.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module KGBotka.DiscordThread 5 | ( DiscordThreadParams(..) 6 | , discordThread 7 | , getRoleByMessageAndEmoji 8 | ) where 9 | 10 | import Control.Concurrent 11 | import Control.Concurrent.STM 12 | import Control.Exception 13 | import Control.Monad 14 | import Control.Monad.Trans.Eval 15 | import Control.Monad.Trans.Except 16 | import Control.Monad.Trans.State.Strict 17 | import qualified Data.Map as M 18 | import Data.Maybe 19 | import qualified Data.Text as T 20 | import Data.Word 21 | import qualified Database.SQLite.Simple as Sqlite 22 | import Database.SQLite.Simple (NamedParam(..)) 23 | import Database.SQLite.Simple.QQ 24 | import Discord 25 | import Discord.Requests 26 | import qualified Discord.Requests as R 27 | import Discord.Types 28 | import KGBotka.Command 29 | import KGBotka.Config 30 | import KGBotka.DiscordLog 31 | import KGBotka.Eval 32 | import KGBotka.Log 33 | import KGBotka.Markov 34 | import qualified KGBotka.Monitor as Monitor 35 | import KGBotka.Queue 36 | import KGBotka.Settings 37 | import KGBotka.Sqlite 38 | import qualified Network.HTTP.Client as HTTP 39 | import Text.Printf 40 | 41 | data DiscordThreadParams = DiscordThreadParams 42 | { dtpConfig :: !(Maybe ConfigDiscord) 43 | , dtpLogQueue :: !(WriteQueue LogEntry) 44 | , dtpSqliteConnection :: !(MVar Sqlite.Connection) 45 | , dtpExitMonitor :: !Monitor.T 46 | , dtpManager :: !HTTP.Manager 47 | , dtpFridayGistUpdateRequired :: !(MVar ()) 48 | , dtpMarkovQueue :: !(WriteQueue MarkovCommand) 49 | } 50 | 51 | data DiscordThreadState = DiscordThreadState 52 | { dtsLogQueue :: !(WriteQueue LogEntry) 53 | , dtsSqliteConnection :: !(MVar Sqlite.Connection) 54 | , dtsManager :: !HTTP.Manager 55 | , dtsExitMonitor :: !Monitor.T 56 | -- TODO(#173): replace dtsCurrentUser :: !(MVar User) with !(Maybe User) 57 | , dtsCurrentUser :: !(MVar User) 58 | , dtsFridayGistUpdateRequired :: !(MVar ()) 59 | , dtsMarkovQueue :: !(WriteQueue MarkovCommand) 60 | } 61 | 62 | instance ProvidesLogging DiscordThreadState where 63 | logEntry dts = logEntry $ dtsLogQueue dts 64 | 65 | instance ProvidesLogging DiscordThreadParams where 66 | logEntry dtp = logEntry $ dtpLogQueue dtp 67 | 68 | discordThread :: DiscordThreadParams -> IO () 69 | discordThread dtp = 70 | case dtpConfig dtp of 71 | Just config -> do 72 | currentUser <- newEmptyMVar 73 | let dts = 74 | DiscordThreadState 75 | { dtsLogQueue = dtpLogQueue dtp 76 | , dtsSqliteConnection = dtpSqliteConnection dtp 77 | , dtsExitMonitor = dtpExitMonitor dtp 78 | , dtsManager = dtpManager dtp 79 | , dtsCurrentUser = currentUser 80 | , dtsFridayGistUpdateRequired = dtpFridayGistUpdateRequired dtp 81 | , dtsMarkovQueue = dtpMarkovQueue dtp 82 | } 83 | userFacingError <- 84 | runDiscord $ 85 | def 86 | { discordToken = configDiscordToken config 87 | , discordOnEvent = eventHandler dts 88 | , discordOnStart = discordThreadOnStart dts 89 | } 90 | logEntry dtp $ LogEntry "DISCORD" userFacingError 91 | Nothing -> 92 | logEntry dtp $ 93 | LogEntry "DISCORD" "[ERROR] Discord configuration not found" 94 | 95 | discordThreadOnStart :: DiscordThreadState -> DiscordHandle -> IO () 96 | discordThreadOnStart dts dis = do 97 | response <- restCall dis GetCurrentUser 98 | case response of 99 | Right user -> putMVar (dtsCurrentUser dts) user 100 | Left err -> logEntry dts $ LogEntry "DISCORD" $ T.pack $ show err 101 | 102 | getRoleByMessageAndEmoji :: 103 | Sqlite.Connection -> MessageId -> T.Text -> IO (Maybe RoleId) 104 | getRoleByMessageAndEmoji dbConn msgId emoId = 105 | fmap (Snowflake . Sqlite.fromOnly) . listToMaybe <$> 106 | Sqlite.queryNamed 107 | dbConn 108 | [sql|SELECT roleId FROM RoleEmojiAssoc 109 | WHERE msgId = :msgId 110 | AND emojiId = :emoId |] 111 | [":msgId" := (fromIntegral msgId :: Word64), ":emoId" := emoId] 112 | 113 | -- TODO(#207): Reaction Role assignment mechanism doesn't have a convenient interface 114 | eventHandler :: DiscordThreadState -> DiscordHandle -> Event -> IO () 115 | eventHandler dts dis (MessageReactionAdd reactionInfo) = do 116 | maybeRole <- 117 | catch 118 | (withLockedTransaction (dtsSqliteConnection dts) $ \dbConn -> 119 | getRoleByMessageAndEmoji 120 | dbConn 121 | (reactionMessageId reactionInfo) 122 | (maybe (emojiName $ reactionEmoji reactionInfo) (T.pack . show) $ 123 | emojiId $ reactionEmoji reactionInfo)) 124 | (\e -> do 125 | logEntry dts $ LogEntry "DISCORD" $ T.pack $ show (e :: SomeException) 126 | return Nothing) 127 | case (maybeRole, reactionGuildId reactionInfo) of 128 | (Just rId, Just gId) -> 129 | void $restCall dis $ 130 | AddGuildMemberRole gId (reactionUserId reactionInfo) rId 131 | _ -> return () 132 | eventHandler dts dis (MessageReactionRemove reactionInfo) = do 133 | maybeRole <- 134 | catch 135 | (withLockedTransaction (dtsSqliteConnection dts) $ \dbConn -> 136 | getRoleByMessageAndEmoji 137 | dbConn 138 | (reactionMessageId reactionInfo) 139 | (maybe (emojiName $ reactionEmoji reactionInfo) (T.pack . show) $ 140 | emojiId $ reactionEmoji reactionInfo)) 141 | (\e -> do 142 | logEntry dts $ LogEntry "DISCORD" $ T.pack $ show (e :: SomeException) 143 | return Nothing) 144 | case (maybeRole, reactionGuildId reactionInfo) of 145 | (Just rId, Just gId) -> 146 | void $ 147 | restCall dis $ RemoveGuildMemberRole gId (reactionUserId reactionInfo) rId 148 | _ -> return () 149 | eventHandler dts dis (MessageCreate m) 150 | | not (fromBot m) && isPing (messageText m) = 151 | void $ 152 | restCall dis (R.CreateReaction (messageChannel m, messageId m) "hearts") 153 | | not (fromBot m) = do 154 | withMVar (dtsSqliteConnection dts) $ \dbConn -> 155 | catch 156 | (Sqlite.withTransaction dbConn $ do 157 | logEntry dts $ 158 | LogEntry "DISCORD" $ 159 | T.pack $ printf "%s: %s" (show $ messageAuthor m) (messageText m) 160 | -- TODO(#109): DiscordThread doesn't cache the guilds 161 | guild <- 162 | case messageGuild m of 163 | Just guildId' -> do 164 | resGuild <- restCall dis $ R.GetGuild guildId' 165 | case resGuild of 166 | Right guild' -> return $ Just guild' 167 | Left restError -> do 168 | logEntry dts $ LogEntry "DISCORD" $ T.pack $ show restError 169 | return Nothing 170 | Nothing -> do 171 | logEntry dts $ 172 | LogEntry "DISCORD" "[WARN] Message was not sent in a Guild" 173 | return Nothing 174 | guildMember <- 175 | case guild of 176 | Just guild' -> do 177 | res <- 178 | restCall dis $ 179 | R.GetGuildMember (guildId guild') (userId $ messageAuthor m) 180 | case res of 181 | Right guildMember' -> return $ Just guildMember' 182 | Left restError -> do 183 | logEntry dts $ LogEntry "DISCORD" $ T.pack $ show restError 184 | return Nothing 185 | Nothing -> do 186 | logEntry dts $ 187 | LogEntry 188 | "DISCORD" 189 | "[WARN] Recieved a message outside of a Guild" 190 | return Nothing 191 | logMessage 192 | dbConn 193 | (messageGuild m) 194 | (messageChannel m) 195 | (userId $ messageAuthor m) 196 | (userName $ messageAuthor m) $ 197 | messageText m 198 | atomically $ 199 | writeQueue (dtsMarkovQueue dts) $ NewSentence $ messageText m 200 | settings <- fetchSettings dbConn 201 | case parseCommandPipe 202 | (settingsCallPrefix settings) 203 | (PipeSuffix "|") 204 | (messageText m) of 205 | [] -> return () 206 | -- when 207 | -- (isJust $ 208 | -- find (\u -> Just (userId u) == (userId <$> currentUser)) $ 209 | -- messageMentions m) $ do 210 | -- markovResponse <- genMarkovSentence dbConn 211 | -- void $ 212 | -- restCall dis $ 213 | -- R.CreateMessage (messageChannel m) $ 214 | -- T.pack $ 215 | -- printf 216 | -- "<@!%d> %s" 217 | -- ((fromIntegral $ userId $ messageAuthor m) :: Word64) 218 | -- markovResponse 219 | pipe -> do 220 | evalResult <- 221 | runExceptT $ 222 | evalStateT (runEvalT $ evalCommandPipe pipe) $ 223 | EvalContext 224 | { ecVars = M.empty 225 | , ecSqliteConnection = dbConn 226 | , ecExitMonitor = dtsExitMonitor dts 227 | , ecPlatformContext = 228 | Edc 229 | EvalDiscordContext 230 | { edcAuthor = messageAuthor m 231 | , edcGuild = guild 232 | , edcRoles = 233 | concat $ 234 | maybeToList (memberRoles <$> guildMember) 235 | } 236 | , ecLogQueue = dtsLogQueue dts 237 | , ecManager = dtsManager dts 238 | , ecFridayGistUpdateRequired = 239 | dtsFridayGistUpdateRequired dts 240 | } 241 | case evalResult of 242 | Right commandResponse -> 243 | void $ 244 | restCall dis $ 245 | R.CreateMessage (messageChannel m) commandResponse 246 | Left (EvalError userMsg) -> 247 | void $ 248 | restCall dis (R.CreateMessage (messageChannel m) userMsg)) 249 | (\e -> 250 | logEntry dts $ LogEntry "SQLITE" $ T.pack $ show (e :: SomeException)) 251 | pure () 252 | eventHandler _ _ _ = pure () 253 | 254 | fromBot :: Message -> Bool 255 | fromBot m = userIsBot (messageAuthor m) 256 | 257 | isPing :: T.Text -> Bool 258 | isPing = ("ping" `T.isPrefixOf`) . T.toLower 259 | -------------------------------------------------------------------------------- /src/KGBotka/Eval.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | 5 | module KGBotka.Eval 6 | ( EvalContext(..) 7 | , EvalPlatformContext(..) 8 | , EvalTwitchContext(..) 9 | , EvalDiscordContext(..) 10 | , EvalReplContext(..) 11 | , evalCommandCall 12 | , evalCommandPipe 13 | , evalExpr 14 | , EvalError(..) 15 | ) where 16 | 17 | import Control.Applicative 18 | import Control.Concurrent 19 | import Control.Monad 20 | import Control.Monad.IO.Class 21 | import Control.Monad.Trans.Class 22 | import Control.Monad.Trans.Eval 23 | import Control.Monad.Trans.Except 24 | import Control.Monad.Trans.Extra 25 | import Control.Monad.Trans.Maybe 26 | import Data.Array 27 | import Data.Bifunctor (first) 28 | import qualified Data.ByteString.Lazy as BS 29 | import Data.Foldable 30 | import qualified Data.Map as M 31 | import Data.Maybe 32 | import qualified Data.Text as T 33 | import qualified Data.Text.Encoding as TE 34 | import Data.Time 35 | import Data.Word 36 | import qualified Database.SQLite.Simple as Sqlite 37 | import Database.SQLite.Simple.QQ 38 | import Discord.Types 39 | import KGBotka.Asciify 40 | import KGBotka.Bttv 41 | import KGBotka.Calc 42 | import KGBotka.Command 43 | import KGBotka.Config 44 | import KGBotka.Expr 45 | import KGBotka.Ffz 46 | import KGBotka.Flip 47 | import KGBotka.Friday 48 | import KGBotka.Log 49 | import KGBotka.Markov 50 | import qualified KGBotka.Monitor as Monitor 51 | import KGBotka.Parser 52 | import KGBotka.Queue 53 | import KGBotka.Roles 54 | import KGBotka.TwitchAPI 55 | import KGBotka.Xkcd 56 | import qualified Network.HTTP.Client as HTTP 57 | import Network.Socket (SockAddr) 58 | import Network.URI 59 | import Text.Printf 60 | import qualified Text.Regex.Base.RegexLike as Regex 61 | import Text.Regex.TDFA (defaultCompOpt, defaultExecOpt) 62 | import Text.Regex.TDFA.String 63 | 64 | data EvalTwitchContext = EvalTwitchContext 65 | { etcSenderId :: !TwitchUserId 66 | , etcSenderName :: !T.Text 67 | -- TODO(#80): evalContextTwitchEmotes should be a list of some kind of emote type 68 | , etcTwitchEmotes :: !(Maybe T.Text) 69 | , etcChannel :: !TwitchIrcChannel 70 | , etcBadgeRoles :: ![TwitchBadgeRole] 71 | , etcRoles :: ![TwitchRole] 72 | , etcConfigTwitch :: !ConfigTwitch 73 | } 74 | 75 | data EvalDiscordContext = EvalDiscordContext 76 | { edcAuthor :: !User 77 | , edcGuild :: !(Maybe Guild) 78 | , edcRoles :: ![Snowflake] 79 | } 80 | 81 | data EvalReplContext = EvalReplContext 82 | { ercTwitchChannel :: Maybe TwitchIrcChannel 83 | , ercConfigTwitch :: Maybe ConfigTwitch 84 | , ercConnAddr :: !SockAddr 85 | } 86 | 87 | data EvalPlatformContext 88 | = Etc EvalTwitchContext 89 | | Edc EvalDiscordContext 90 | | Erc EvalReplContext 91 | 92 | data EvalContext = EvalContext 93 | { ecVars :: !(M.Map T.Text T.Text) 94 | , ecSqliteConnection :: !Sqlite.Connection 95 | , ecManager :: !HTTP.Manager 96 | , ecLogQueue :: !(WriteQueue LogEntry) 97 | , ecExitMonitor :: Monitor.T 98 | , ecFridayGistUpdateRequired :: !(MVar ()) 99 | , ecPlatformContext :: !EvalPlatformContext 100 | } 101 | 102 | instance ProvidesLogging EvalContext where 103 | logEntry ec = logEntry $ ecLogQueue ec 104 | 105 | logEntryEval :: LogEntry -> Eval () 106 | logEntryEval entry = do 107 | context <- getEval 108 | liftIO $ logEntry context entry 109 | 110 | newtype EvalError = 111 | EvalError T.Text 112 | deriving (Show) 113 | 114 | type Eval = EvalT EvalContext EvalError IO 115 | 116 | listToMaybeLast :: [a] -> Maybe a 117 | listToMaybeLast [] = Nothing 118 | listToMaybeLast [x] = Just x 119 | listToMaybeLast (_:xs) = listToMaybeLast xs 120 | 121 | senderMentionOfContext :: EvalPlatformContext -> Maybe T.Text 122 | senderMentionOfContext (Etc EvalTwitchContext {etcSenderName = name}) = 123 | Just name 124 | senderMentionOfContext (Edc EvalDiscordContext {edcAuthor = author}) = 125 | Just $ T.pack $ printf "<@!%d>" ((fromIntegral $ userId author) :: Word64) 126 | senderMentionOfContext (Erc EvalReplContext {}) = Nothing 127 | 128 | configTwitchOfContext :: EvalPlatformContext -> Maybe ConfigTwitch 129 | configTwitchOfContext (Etc EvalTwitchContext {etcConfigTwitch = config'}) = 130 | Just config' 131 | configTwitchOfContext (Erc EvalReplContext {ercConfigTwitch = config'}) = 132 | config' 133 | configTwitchOfContext _ = Nothing 134 | 135 | channelNameOfContext :: EvalPlatformContext -> T.Text 136 | channelNameOfContext (Etc EvalTwitchContext {etcChannel = channel}) = 137 | twitchIrcChannelName channel 138 | channelNameOfContext _ = "" 139 | 140 | evalCommandCall :: CommandCall -> Eval T.Text 141 | evalCommandCall (CommandCall name args) = do 142 | dbConn <- ecSqliteConnection <$> getEval 143 | command <- liftIO $ commandByName dbConn name 144 | case command of 145 | Just Command { commandId = commandIdent 146 | , commandCode = code 147 | , commandTimes = times 148 | } -> do 149 | day <- liftIO $ utctDay <$> getCurrentTime 150 | let (yearNum, monthNum, dayNum) = toGregorian day 151 | platformContext <- ecPlatformContext <$> getEval 152 | -- TODO(#211): make evalCommandCall parse command call input according to command's args regex 153 | modifyEval $ ecVarsModify $ M.insert "1" args 154 | modifyEval $ ecVarsModify $ M.insert "times" $ T.pack $ show times 155 | case senderMentionOfContext platformContext of 156 | Just sender -> modifyEval $ ecVarsModify $ M.insert "sender" sender 157 | Nothing -> return () 158 | modifyEval $ ecVarsModify $ M.insert "year" $ T.pack $ show yearNum 159 | modifyEval $ ecVarsModify $ M.insert "month" $ T.pack $ show monthNum 160 | modifyEval $ ecVarsModify $ M.insert "day" $ T.pack $ show dayNum 161 | modifyEval $ ecVarsModify $ M.insert "date" $ T.pack $ showGregorian day 162 | -- TODO(#174): %tchannel is incosistent with the general variable behaviour 163 | -- Usually when variable is not available it throws an error. But %tchannel doesn't! 164 | -- It's simply empty on Discord. This kind of inconsistency is not acceptable. 165 | modifyEval $ 166 | ecVarsModify $ 167 | M.insert "tchannel" $ channelNameOfContext platformContext 168 | case platformContext of 169 | Etc etc -> do 170 | let senderId = etcSenderId etc 171 | cooledDown <- 172 | liftIO $ 173 | isCommandCooleddown dbConn Nothing (Just senderId) commandIdent 174 | unless cooledDown $ 175 | throwExceptEval $ 176 | EvalError $ 177 | "@" <> etcSenderName etc <> " The command has not cooled down yet" 178 | liftIO $ logCommand dbConn Nothing (Just senderId) commandIdent args 179 | Edc edc -> do 180 | let senderId = DiscordUserId $ userId $ edcAuthor edc 181 | cooledDown <- 182 | liftIO $ 183 | isCommandCooleddown dbConn (Just senderId) Nothing commandIdent 184 | unless cooledDown $ 185 | throwExceptEval $ 186 | EvalError $ 187 | T.pack $ 188 | printf 189 | "<@!%d> The command has not cooled down yet" 190 | ((fromIntegral $ userId $ edcAuthor edc) :: Word64) 191 | liftIO $ logCommand dbConn (Just senderId) Nothing commandIdent args 192 | Erc _ -> 193 | throwExceptEval $ 194 | EvalError "Chat commands are not supported in the REPL context" 195 | codeAst <- 196 | liftExceptT $ 197 | withExceptT (EvalError . T.pack . show) $ 198 | except (snd <$> runParser exprs code) 199 | responseText <- evalExprs codeAst 200 | liftIO $ bumpCommandTimes dbConn commandIdent 201 | return responseText 202 | Nothing -> return "" 203 | 204 | evalCommandPipe :: [CommandCall] -> Eval T.Text 205 | evalCommandPipe = 206 | foldlM (\args -> evalCommandCall . ccArgsModify (`T.append` args)) "" 207 | 208 | ecVarsModify :: 209 | (M.Map T.Text T.Text -> M.Map T.Text T.Text) -> EvalContext -> EvalContext 210 | ecVarsModify f context = context {ecVars = f $ ecVars context} 211 | 212 | failIfNotTrusted :: Eval () 213 | failIfNotTrusted = do 214 | platformContext <- ecPlatformContext <$> getEval 215 | case platformContext of 216 | Etc etc -> 217 | let roles = etcRoles etc 218 | badgeRoles = etcBadgeRoles etc 219 | in when (null roles && null badgeRoles) $ 220 | throwExceptEval $ EvalError "Only for trusted users" 221 | Edc edc -> 222 | when (null $ edcRoles edc) $ 223 | throwExceptEval $ EvalError "Only for trusted users" 224 | Erc _ -> return () 225 | 226 | failIfNotAuthority :: Eval () 227 | failIfNotAuthority = do 228 | platformContext <- ecPlatformContext <$> getEval 229 | case platformContext of 230 | Etc EvalTwitchContext {etcBadgeRoles = badgeRoles} 231 | | TwitchBroadcaster `elem` badgeRoles -> return () 232 | Edc EvalDiscordContext { edcAuthor = User {userId = authorId} 233 | , edcGuild = Just Guild {guildOwnerId = ownerId} 234 | } 235 | | authorId == ownerId -> return () 236 | Erc EvalReplContext {} -> return () 237 | _ -> throwExceptEval $ EvalError "Only for mr strimmer :)" 238 | 239 | requireFridayGistUpdate :: Eval () 240 | requireFridayGistUpdate = do 241 | fridayGistUpdateRequired <- ecFridayGistUpdateRequired <$> getEval 242 | void $ liftIO $ tryPutMVar fridayGistUpdateRequired () 243 | 244 | wordsPerMinuteOnTwitch :: Sqlite.Connection -> T.Text -> IO Int 245 | wordsPerMinuteOnTwitch dbConn input = do 246 | let term = fromMaybe "" $ listToMaybe $ textAsTerms input 247 | messages <- 248 | map Sqlite.fromOnly <$> 249 | Sqlite.queryNamed 250 | dbConn 251 | [sql| select message from TwitchLog 252 | where messageTime > datetime('now', '-1 minute') |] 253 | [] 254 | let n = length $ filter (== T.toUpper term) $ concatMap textAsTerms messages 255 | return n 256 | 257 | wordsPerMinuteOnDiscord :: Sqlite.Connection -> T.Text -> IO Int 258 | wordsPerMinuteOnDiscord dbConn input = do 259 | let term = fromMaybe "" $ listToMaybe $ textAsTerms input 260 | messages <- 261 | map Sqlite.fromOnly <$> 262 | Sqlite.queryNamed 263 | dbConn 264 | [sql| select message from DiscordLog 265 | where messageTime > datetime('now', '-1 minute') |] 266 | [] 267 | let n = length $ filter (== T.toUpper term) $ concatMap textAsTerms messages 268 | return n 269 | 270 | evalExpr :: Expr -> Eval T.Text 271 | evalExpr (TextExpr t) = return t 272 | evalExpr (FunCallExpr "or" args) = 273 | fromMaybe "" . listToMaybe . dropWhile T.null <$> mapM evalExpr args 274 | evalExpr (FunCallExpr "urlencode" args) = 275 | T.concat . map (T.pack . encodeURI . T.unpack) <$> mapM evalExpr args 276 | where 277 | encodeURI = escapeURIString (const False) 278 | evalExpr (FunCallExpr "wpm" args) = do 279 | platformContext <- ecPlatformContext <$> getEval 280 | word <- listToMaybe <$> mapM evalExpr args 281 | dbConn <- ecSqliteConnection <$> getEval 282 | case platformContext of 283 | Etc _ -> 284 | case word of 285 | Just word' -> do 286 | n <- liftIO $ wordsPerMinuteOnTwitch dbConn word' 287 | return $ T.pack $ printf "%d %s per minute" n word' 288 | Nothing -> return "" 289 | Edc _ -> 290 | case word of 291 | Just word' -> do 292 | n <- liftIO $ wordsPerMinuteOnDiscord dbConn word' 293 | return $ T.pack $ printf "%d %s per minute" n word' 294 | Nothing -> return "" 295 | -- TODO(#256): Add %wpm support for REPL evaluation context 296 | Erc _ -> throwExceptEval $ EvalError "%wpm does not work in REPL yet Kapp" 297 | evalExpr (FunCallExpr "markov" args) = do 298 | prefix <- fmap T.words . listToMaybe <$> mapM evalExpr args 299 | dbConn <- ecSqliteConnection <$> getEval 300 | (T.unwords (initSafe (fromMaybe [] prefix) <> [""]) <>) <$> 301 | liftIO (genMarkovSentence dbConn (prefix >>= lastMaybe)) 302 | where 303 | initSafe :: [a] -> [a] 304 | initSafe [] = [] 305 | initSafe xs = init xs 306 | lastMaybe :: [a] -> Maybe a 307 | lastMaybe [] = Nothing 308 | lastMaybe [x] = Just x 309 | lastMaybe (_:xs) = lastMaybe xs 310 | evalExpr (FunCallExpr "flip" args) = 311 | T.concat . map flipText <$> mapM evalExpr args 312 | -- FIXME(#38): %nextvideo does not inform how many times a video was suggested 313 | evalExpr (FunCallExpr "nextvideo" _) = do 314 | failIfNotAuthority 315 | dbConn <- ecSqliteConnection <$> getEval 316 | fridayVideo <- 317 | liftExceptT $ 318 | maybeToExceptT (EvalError "Video queue is empty") $ nextVideo dbConn 319 | requireFridayGistUpdate 320 | return $ fridayVideoAsMessage fridayVideo 321 | evalExpr (FunCallExpr "trusted" args) = do 322 | failIfNotTrusted 323 | fromMaybe "" . listToMaybeLast <$> mapM evalExpr args 324 | evalExpr (FunCallExpr "authority" args) = do 325 | failIfNotAuthority 326 | fromMaybe "" . listToMaybeLast <$> mapM evalExpr args 327 | evalExpr (FunCallExpr "curl" args) = do 328 | failIfNotTrusted 329 | location <- T.concat <$> mapM evalExpr args 330 | parsedLocation <- lift $ HTTP.parseRequest $ T.unpack location 331 | man <- ecManager <$> getEval 332 | result <- lift $ HTTP.httpLbs parsedLocation man 333 | return $ TE.decodeUtf8 $ BS.toStrict $ HTTP.responseBody result 334 | -- FIXME(#39): %friday does not inform how many times a video was suggested 335 | evalExpr (FunCallExpr "shutdown" _) = do 336 | platformContext <- ecPlatformContext <$> getEval 337 | exitMonitor <- ecExitMonitor <$> getEval 338 | case platformContext of 339 | Etc EvalTwitchContext { etcSenderId = senderId 340 | , etcSenderName = senderName 341 | , etcChannel = channel 342 | } -> 343 | logEntryEval $ 344 | LogEntry "SHUTDOWN" $ 345 | T.pack $ 346 | printf 347 | "Requested a shutdown from Twitch context: senderId = %s, senderName = %s, channel = %s" 348 | (show senderId) 349 | senderName 350 | (show channel) 351 | Edc EvalDiscordContext {edcAuthor = author, edcGuild = guild} -> 352 | logEntryEval $ 353 | LogEntry "SHUTDOWN" $ 354 | T.pack $ 355 | printf 356 | "Requested a shutdown from Discord context: author = %s, guild = %s" 357 | (show author) 358 | (show guild) 359 | Erc EvalReplContext {ercConnAddr = connAddr} -> 360 | logEntryEval $ 361 | LogEntry "SHUTDOWN" $ 362 | T.pack $ 363 | printf 364 | "Request a shutdown from REPL context: connAddr = %s" 365 | (show connAddr) 366 | liftIO $ Monitor.notify exitMonitor 367 | return "" 368 | evalExpr (FunCallExpr "friday" args) = do 369 | failIfNotTrusted 370 | submissionText <- T.concat <$> mapM evalExpr args 371 | case ytLinkId submissionText of 372 | Right _ -> do 373 | platformContext <- ecPlatformContext <$> getEval 374 | dbConn <- ecSqliteConnection <$> getEval 375 | let (authorDisplayName, authorId) = 376 | case platformContext of 377 | Etc etc -> 378 | let TwitchUserId senderId = etcSenderId etc 379 | in (etcSenderName etc, senderId) 380 | Edc edc -> 381 | ( userName $ edcAuthor edc 382 | , T.pack $ show $ userId $ edcAuthor edc) 383 | Erc _ -> ("Admin", "69") 384 | liftIO $ 385 | submitVideo dbConn submissionText (AuthorId authorId) authorDisplayName 386 | requireFridayGistUpdate 387 | return "Added your video to suggestions" 388 | Left Nothing -> 389 | throwExceptEval $ EvalError "Your suggestion should contain YouTube link" 390 | Left (Just failReason) -> do 391 | logEntryEval $ 392 | LogEntry "YOUTUBE" $ 393 | "An error occured while parsing YouTube link: " <> T.pack failReason 394 | throwExceptEval $ 395 | EvalError 396 | "Something went wrong while parsing your subsmission. \ 397 | \We are already looking into it. Kapp" 398 | evalExpr (FunCallExpr "asciify" args) = do 399 | failIfNotTrusted 400 | platformContext <- ecPlatformContext <$> getEval 401 | dbConn <- ecSqliteConnection <$> getEval 402 | emoteNameArg <- T.concat <$> mapM evalExpr args 403 | manager <- ecManager <$> getEval 404 | image <- 405 | case platformContext of 406 | Erc erc -> do 407 | let channel = ercTwitchChannel erc 408 | let bttvEmoteUrl = 409 | bttvEmoteImageUrl <$> 410 | getBttvEmoteByName dbConn emoteNameArg channel 411 | let ffzEmoteUrl = 412 | ffzEmoteImageUrl <$> getFfzEmoteByName dbConn emoteNameArg channel 413 | emoteUrl <- 414 | liftExceptT $ 415 | maybeToExceptT 416 | (EvalError "No emote found") 417 | (bttvEmoteUrl <|> ffzEmoteUrl) 418 | liftIO $ 419 | runExceptT 420 | (T.unlines . T.splitOn " " <$> asciifyUrl dbConn manager emoteUrl) 421 | Etc etc -> do 422 | let twitchEmoteUrl = 423 | let emotes = etcTwitchEmotes etc 424 | makeTwitchEmoteUrl emoteName = 425 | "https://static-cdn.jtvnw.net/emoticons/v1/" <> emoteName <> 426 | "/3.0" 427 | in makeTwitchEmoteUrl <$> hoistMaybe emotes 428 | let channel = etcChannel etc 429 | let bttvEmoteUrl = 430 | bttvEmoteImageUrl <$> 431 | getBttvEmoteByName dbConn emoteNameArg (Just channel) 432 | let ffzEmoteUrl = 433 | ffzEmoteImageUrl <$> 434 | getFfzEmoteByName dbConn emoteNameArg (Just channel) 435 | emoteUrl <- 436 | liftExceptT $ 437 | maybeToExceptT 438 | (EvalError "No emote found") 439 | (twitchEmoteUrl <|> bttvEmoteUrl <|> ffzEmoteUrl) 440 | liftIO $ runExceptT $ asciifyUrl dbConn manager emoteUrl 441 | Edc _ -> do 442 | regex <- 443 | liftExceptT $ 444 | withExceptT (EvalError . T.pack) $ 445 | except $ compile defaultCompOpt defaultExecOpt "<\\:.+\\:([0-9]+)>" 446 | case execute regex (T.unpack emoteNameArg) of 447 | Right (Just matches) -> 448 | case map (T.pack . flip Regex.extract (T.unpack emoteNameArg)) $ 449 | elems matches of 450 | [_, discordEmoteId] -> 451 | liftIO $ 452 | runExceptT 453 | (T.unlines . T.splitOn " " <$> 454 | asciifyUrl 455 | dbConn 456 | manager 457 | ("https://cdn.discordapp.com/emojis/" <> discordEmoteId <> 458 | ".png")) 459 | _ -> throwExceptEval $ EvalError "No emote found" 460 | _ -> throwExceptEval $ EvalError "No emote found" 461 | case image of 462 | Right image' -> return image' 463 | Left errorMessage -> do 464 | logEntryEval $ LogEntry "ASCIIFY" $ T.pack errorMessage 465 | return "" 466 | evalExpr (FunCallExpr "tsify" args) = do 467 | text <- T.concat <$> mapM evalExpr args 468 | return $ 469 | T.concatMap 470 | (\case 471 | 'c' -> "ts" 472 | 'C' -> "Ts" 473 | x -> T.pack [x]) 474 | text 475 | evalExpr (FunCallExpr "assrole" rawArgs) = do 476 | failIfNotAuthority 477 | cookedArgs <- mapM evalExpr rawArgs 478 | case cookedArgs of 479 | [roleName', userName'] -> do 480 | platformContext <- ecPlatformContext <$> getEval 481 | dbConn <- ecSqliteConnection <$> getEval 482 | manager <- ecManager <$> getEval 483 | let config' = configTwitchOfContext platformContext 484 | case config' of 485 | Just config -> do 486 | maybeRole <- liftIO $ getTwitchRoleByName dbConn roleName' 487 | response <- liftIO $ getUsersByLogins manager config [userName'] 488 | case (response, maybeRole) of 489 | (Right [twitchUser], Just role') -> do 490 | liftIO $ 491 | assTwitchRoleToUser dbConn (twitchRoleId role') $ 492 | twitchUserId twitchUser 493 | return "Assigned the role" 494 | (Right _, Just _) -> 495 | throwExceptEval $ EvalError "User does not exist! D:" 496 | (Left twitchErr, _) -> do 497 | logEntryEval $ LogEntry "TWITCHAPI" $ T.pack (show twitchErr) 498 | throwExceptEval $ 499 | EvalError 500 | "Could not assign the role. Twitch API returned an error. Check out logs." 501 | (_, Nothing) -> do 502 | logEntryEval $ LogEntry "TWITCHAPI" "Such role does not exist" 503 | throwExceptEval $ 504 | EvalError $ 505 | T.pack $ 506 | printf 507 | "Could not assign the role. The role `%s` does not exist" 508 | roleName' 509 | Nothing -> do 510 | logEntryEval $ LogEntry "TWITCHAPI" "No twitch configuration" 511 | throwExceptEval $ 512 | EvalError "Could not assign the role. Twitch config is missing." 513 | cookedArgs' -> 514 | throwExceptEval $ 515 | EvalError $ 516 | T.pack $ 517 | printf "%assrole accepts 2 arguments, but %d was provided" $ 518 | length cookedArgs' 519 | evalExpr (FunCallExpr "help" args) = do 520 | name <- T.concat <$> mapM evalExpr args 521 | dbConn <- ecSqliteConnection <$> getEval 522 | maybeCommand <- liftIO $ commandByName dbConn name 523 | case maybeCommand of 524 | Just Command {commandCode = code} -> 525 | return $ "Command `" <> name <> "` defined as `" <> code <> "`" 526 | Nothing -> return $ "Command `" <> name <> " does not exist" 527 | evalExpr (FunCallExpr "xkcd" args) = do 528 | probablyTerm <- listToMaybe <$> mapM evalExpr args 529 | dbConn <- ecSqliteConnection <$> getEval 530 | case probablyTerm of 531 | Just term -> do 532 | probablyXkcd <- liftIO $ searchXkcdInDbByTerm dbConn $ textAsTerms term 533 | case probablyXkcd of 534 | Just Xkcd {xkcdNum = num} -> 535 | return $ T.pack $ printf "https://xkcd.com/%d/" num 536 | Nothing -> return "No xkcd with such term was found" 537 | Nothing -> throwExceptEval $ EvalError "No term was provided" 538 | evalExpr (FunCallExpr "uptime" _) = do 539 | platformContext <- ecPlatformContext <$> getEval 540 | case platformContext of 541 | Etc etc -> do 542 | manager <- ecManager <$> getEval 543 | let channel = etcChannel etc 544 | stream <- 545 | liftIO $ 546 | getStreamByLogin 547 | manager 548 | (etcConfigTwitch etc) 549 | (twitchIrcChannelName channel) 550 | case stream of 551 | Right (Just TwitchStream {tsStartedAt = startedAt}) -> do 552 | now <- liftIO getCurrentTime 553 | return $ humanReadableDiffTime $ diffUTCTime now startedAt 554 | Right Nothing -> return "Not even streaming LULW" 555 | Left errorMessage -> do 556 | logEntryEval $ LogEntry "TWITCHAPI" $ T.pack $ show errorMessage 557 | return "" 558 | Edc _ -> throwExceptEval $ EvalError "Uptime doesn't work in Discord" 559 | Erc _ -> throwExceptEval $ EvalError "Uptime doesn't work in REPL" 560 | evalExpr (FunCallExpr "eval" args) = do 561 | failIfNotAuthority 562 | code <- T.concat <$> mapM evalExpr args 563 | codeAst <- 564 | liftExceptT $ 565 | withExceptT (EvalError . T.pack . show) $ 566 | except (snd <$> runParser exprs code) 567 | evalExprs codeAst 568 | evalExpr (FunCallExpr "calc" args) = do 569 | mathsExpression <- T.concat <$> mapM evalExpr args 570 | (rest, parsedExpression) <- 571 | exceptEval $ 572 | first parserStopToEvalError $ runParser parseLine mathsExpression 573 | if T.null rest 574 | then do 575 | calcResult <- lift $ runExceptT $ evalCalcExpression parsedExpression 576 | calcResultToEval calcResult 577 | else throwExceptEval $ EvalError "Calc: Incomplete parse PepeHands" 578 | where 579 | parserStopToEvalError EOF = EvalError "Calc: Unexpected EOF" 580 | parserStopToEvalError (SyntaxError msg) = 581 | EvalError $ "Syntax error: " <> msg 582 | -- TODO(#179): There might be a better way to do the job of calcResultToEval 583 | -- instead of unwrapping the ExceptT 584 | calcResultToEval :: Either CalcEvalError Double -> Eval T.Text 585 | calcResultToEval calcResult = 586 | case calcResult of 587 | Left (CalcEvalError e) -> 588 | throwExceptEval $ EvalError ("Evaluation error: " <> e) 589 | Right e -> return $ T.pack $ show e 590 | evalExpr (FunCallExpr "checkchannel" _) = do 591 | platformContext <- ecPlatformContext <$> getEval 592 | case platformContext of 593 | Erc EvalReplContext {ercTwitchChannel = Just channel} -> 594 | return $ twitchIrcChannelName channel 595 | Erc EvalReplContext {ercTwitchChannel = Nothing} -> 596 | throwExceptEval $ EvalError "No channel" 597 | _ -> throwExceptEval $ EvalError "[ERROR] Works only in REPL context" 598 | evalExpr (FunCallExpr "roles" _) = do 599 | platformContext <- ecPlatformContext <$> getEval 600 | case platformContext of 601 | Etc etc -> 602 | return $ 603 | T.pack $ 604 | printf 605 | "@%s Your badge roles: %s. Your custom roles: %s" 606 | (etcSenderName etc) 607 | (show $ etcBadgeRoles etc) 608 | (show $ etcRoles etc) 609 | Edc edc -> 610 | return $ 611 | T.pack $ 612 | printf 613 | "<@!%d> Your roles: %s." 614 | ((fromIntegral $ userId $ edcAuthor edc) :: Word64) 615 | (show $ edcRoles edc) 616 | Erc _ -> 617 | return 618 | "You are in the REPL. You don't need any roles. You can do whatever you want!" 619 | evalExpr (FunCallExpr funame _) = do 620 | vars <- ecVars <$> getEval 621 | liftExceptT $ 622 | maybeToExceptT (EvalError $ "Function `" <> funame <> "` does not exists") $ 623 | hoistMaybe $ M.lookup funame vars 624 | 625 | -- asdjkasd 626 | evalExprs :: [Expr] -> Eval T.Text 627 | evalExprs exprs' = T.concat <$> mapM evalExpr exprs' 628 | 629 | humanReadableDiffTime :: NominalDiffTime -> T.Text 630 | humanReadableDiffTime t 631 | | t < 1.0 = "< 1 second" 632 | | otherwise = 633 | T.unwords $ 634 | map (\(name, amount) -> T.pack (show amount) <> " " <> name) $ 635 | filter ((> 0) . snd) components 636 | where 637 | s :: Int 638 | s = round t 639 | components :: [(T.Text, Int)] 640 | components = 641 | [ ("days" :: T.Text, s `div` secondsInDay) 642 | , ("hours", (s `mod` secondsInDay) `div` secondsInHour) 643 | , ( "minutes" 644 | , ((s `mod` secondsInDay) `mod` secondsInHour) `div` secondsInMinute) 645 | , ( "seconds" 646 | , ((s `mod` secondsInDay) `mod` secondsInHour) `mod` secondsInMinute) 647 | ] 648 | secondsInDay = 24 * secondsInHour 649 | secondsInHour = 60 * secondsInMinute 650 | secondsInMinute = 60 651 | -------------------------------------------------------------------------------- /src/KGBotka/Expr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module KGBotka.Expr where 4 | 5 | import Control.Applicative 6 | import Data.Char 7 | import qualified Data.Text as T 8 | import Data.Tuple 9 | import KGBotka.Parser 10 | 11 | data Expr 12 | = TextExpr T.Text 13 | | FunCallExpr T.Text 14 | [Expr] 15 | deriving (Eq, Show) 16 | 17 | type NameTable = () 18 | 19 | symbol :: Parser T.Text 20 | symbol = notNull "Symbol name cannot be empty" $ takeWhileP isAlphaNum 21 | 22 | stringLiteral :: Parser Expr 23 | stringLiteral = do 24 | _ <- charP '"' 25 | value <- takeWhileP (/= '"') 26 | _ <- charP '"' 27 | return $ TextExpr value 28 | 29 | funCallArg :: Parser Expr 30 | funCallArg = funCall <|> stringLiteral 31 | 32 | funCallArgList :: Parser [Expr] 33 | funCallArgList = do 34 | _ <- charP '(' <* whitespaces 35 | args <- 36 | sepBy funCallArg (whitespaces >> charP ',' >> whitespaces) <|> return [] 37 | _ <- whitespaces >> charP ')' 38 | return args 39 | 40 | funCall :: Parser Expr 41 | funCall = do 42 | name <- charP '%' *> symbol 43 | args <- funCallArgList <|> return [] 44 | return $ FunCallExpr name args 45 | 46 | whitespaces :: Parser T.Text 47 | whitespaces = takeWhileP isSpace 48 | 49 | textBlock :: Parser Expr 50 | textBlock = 51 | Parser $ \input -> 52 | case T.uncons input of 53 | Nothing -> Left EOF 54 | Just ('%', input') -> 55 | return $ fmap (TextExpr . T.cons '%') $ swap $ T.span (/= '%') input' 56 | _ -> return $ fmap TextExpr $ swap $ T.span (/= '%') input 57 | 58 | expr :: Parser Expr 59 | expr = funCall <|> textBlock 60 | 61 | exprs :: Parser [Expr] 62 | exprs = normalizeExprs <$> many expr 63 | where 64 | normalizeExprs :: [Expr] -> [Expr] 65 | normalizeExprs [] = [] 66 | normalizeExprs (TextExpr t1:TextExpr t2:rest) = 67 | normalizeExprs (TextExpr (t1 <> t2) : rest) 68 | normalizeExprs (x:rest) = x : normalizeExprs rest 69 | -------------------------------------------------------------------------------- /src/KGBotka/Ffz.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | 5 | module KGBotka.Ffz 6 | ( FfzEmote(..) 7 | , updateFfzEmotes 8 | , getFfzEmoteByName 9 | ) where 10 | 11 | import Control.Monad.Trans.Class 12 | import Control.Monad.Trans.Except 13 | import Control.Monad.Trans.Maybe 14 | import Data.Aeson 15 | import Data.Aeson.Types 16 | import Data.Foldable 17 | import qualified Data.HashMap.Strict as HM 18 | import Data.List 19 | import qualified Data.Map as M 20 | import Data.Maybe 21 | import Data.Ord 22 | import qualified Data.Text as T 23 | import Database.SQLite.Simple 24 | import Database.SQLite.Simple.QQ 25 | import KGBotka.TwitchAPI 26 | import Network.HTTP.Client 27 | 28 | data FfzEmote = FfzEmote 29 | { ffzEmoteName :: T.Text 30 | , ffzEmoteImageUrl :: T.Text 31 | , ffzEmoteChannel :: Maybe TwitchIrcChannel 32 | } 33 | 34 | -- TODO(#243): updateFfzEmotes does not handle channels that do no exist on FFZ 35 | updateFfzEmoteChannel :: Maybe TwitchIrcChannel -> FfzEmote -> FfzEmote 36 | updateFfzEmoteChannel channel emote = emote {ffzEmoteChannel = channel} 37 | 38 | instance FromRow FfzEmote where 39 | fromRow = FfzEmote <$> field <*> field <*> field 40 | 41 | newtype FfzSet = FfzSet 42 | { ffzSetEmotes :: [FfzEmote] 43 | } 44 | 45 | instance FromJSON FfzSet where 46 | parseJSON (Object v) = FfzSet <$> (v .: "emoticons") 47 | parseJSON invalid = typeMismatch "FfzSet" invalid 48 | 49 | data FfzGlobalRes = FfzGlobalRes 50 | { ffzGlobalResDefaultSets :: [Int] 51 | , ffzGlobalResSets :: M.Map T.Text FfzSet 52 | } 53 | 54 | instance FromJSON FfzGlobalRes where 55 | parseJSON (Object v) = FfzGlobalRes <$> v .: "default_sets" <*> v .: "sets" 56 | parseJSON invalid = typeMismatch "FfzGlobalRes" invalid 57 | 58 | newtype FfzRes = FfzRes 59 | { ffzResEmotes :: [FfzEmote] 60 | } 61 | 62 | instance FromJSON FfzEmote where 63 | parseJSON (Object v) = 64 | FfzEmote <$> v .: "name" <*> (v .: "urls" >>= maxUrl) <*> return Nothing 65 | where 66 | maxUrl :: Value -> Parser T.Text 67 | maxUrl (Object v') = 68 | (\case 69 | Nothing -> typeMismatch "List of FFZ emote urls" $ Object v' 70 | (Just x) -> ("https:" <>) <$> parseJSON x) =<< 71 | pure ((`HM.lookup` v') =<< idx) 72 | where 73 | idx = listToMaybe $ sortOn Down $ HM.keys v' 74 | maxUrl invalid = typeMismatch "FfzEmote" invalid 75 | parseJSON invalid = typeMismatch "FfzEmote" invalid 76 | 77 | instance FromJSON FfzRes where 78 | parseJSON (Object v) = 79 | FfzRes <$> do 80 | setId <- v .: "room" >>= (.: "set") :: Parser Int 81 | v .: "sets" >>= (.: (T.pack $ show setId)) >>= (.: "emoticons") 82 | parseJSON invalid = typeMismatch "FfzRes" invalid 83 | 84 | queryFfzEmotes :: 85 | Manager -> Maybe TwitchIrcChannel -> ExceptT String IO [FfzEmote] 86 | queryFfzEmotes manager Nothing 87 | -- @uri 88 | = do 89 | request <- parseRequest "https://api.frankerfacez.com/v1/set/global" 90 | ffzRes <- ExceptT (eitherDecode . responseBody <$> httpLbs request manager) 91 | return $ 92 | concatMap ffzSetEmotes $ 93 | mapMaybe 94 | (\setId -> M.lookup (T.pack $ show setId) $ ffzGlobalResSets ffzRes) $ 95 | ffzGlobalResDefaultSets ffzRes 96 | queryFfzEmotes manager (Just channel) = 97 | case T.uncons $ twitchIrcChannelText channel of 98 | Just ('#', channelName) 99 | -- @uri 100 | -> do 101 | request <- 102 | parseRequest $ 103 | "https://api.frankerfacez.com/v1/room/" <> T.unpack channelName 104 | response <- lift (eitherDecode . responseBody <$> httpLbs request manager) 105 | except $ 106 | map (updateFfzEmoteChannel $ Just channel) . ffzResEmotes <$> response 107 | _ -> 108 | throwE $ 109 | "Channel name " <> T.unpack (twitchIrcChannelText channel) <> 110 | " does not start with #" 111 | 112 | updateFfzEmotes :: 113 | Connection -> Manager -> Maybe TwitchIrcChannel -> ExceptT String IO () 114 | updateFfzEmotes dbConn manager channel = do 115 | lift $ 116 | executeNamed 117 | dbConn 118 | [sql|DELETE FROM FfzEmotes WHERE channel is :channel;|] 119 | [":channel" := channel] 120 | ffzEmotes <- queryFfzEmotes manager channel 121 | for_ ffzEmotes $ \emote -> 122 | lift $ 123 | executeNamed 124 | dbConn 125 | [sql|INSERT INTO FfzEmotes (name, imageUrl, channel) 126 | VALUES (:name, :imageUrl, :channel)|] 127 | [ ":name" := ffzEmoteName emote 128 | , ":imageUrl" := ffzEmoteImageUrl emote 129 | , ":channel" := ffzEmoteChannel emote 130 | ] 131 | 132 | getFfzEmoteByName :: 133 | Connection -> T.Text -> Maybe TwitchIrcChannel -> MaybeT IO FfzEmote 134 | getFfzEmoteByName dbConn name channel = 135 | MaybeT 136 | (listToMaybe <$> 137 | queryNamed 138 | dbConn 139 | [sql|SELECT name, imageUrl, channel FROM FfzEmotes 140 | WHERE (channel is :channel OR channel is NULL) 141 | AND name is :name|] 142 | [":channel" := channel, ":name" := name]) 143 | -------------------------------------------------------------------------------- /src/KGBotka/Flip.hs: -------------------------------------------------------------------------------- 1 | module KGBotka.Flip where 2 | 3 | import Control.Applicative 4 | import qualified Data.Map as M 5 | import Data.Maybe 6 | import qualified Data.Text as T 7 | import Data.Tuple 8 | 9 | -- https://github.com/doherty/Text-UpsideDown/blob/master/lib/Text/UpsideDown.pm 10 | -- http://www.fileformat.info/convert/text/upside-down-map.htm 11 | flipText :: T.Text -> T.Text 12 | flipText = 13 | T.map (\x -> fromMaybe x (M.lookup x table1 <|> M.lookup x table2)) . 14 | T.reverse 15 | 16 | separateVariable :: [(Char, Char)] 17 | separateVariable = 18 | [ ('\x0021', '\x00A1') 19 | , ('\x0022', '\x201E') 20 | , ('\x0026', '\x214B') 21 | , ('\x0027', '\x002C') 22 | , ('\x0028', '\x0029') 23 | , ('\x002E', '\x02D9') 24 | , ('\x0033', '\x0190') 25 | , ('\x0034', '\x152D') 26 | , ('\x0036', '\x0039') 27 | , ('\x0037', '\x2C62') 28 | , ('\x003B', '\x061B') 29 | , ('\x003C', '\x003E') 30 | , ('\x003F', '\x00BF') 31 | , ('\x0041', '\x2200') 32 | , ('\x0042', '\x10412') 33 | , ('\x0043', '\x2183') 34 | , ('\x0044', '\x25D6') 35 | , ('\x0045', '\x018E') 36 | , ('\x0046', '\x2132') 37 | , ('\x0047', '\x2141') 38 | , ('\x004A', '\x017F') 39 | , ('\x004B', '\x22CA') 40 | , ('\x004C', '\x2142') 41 | , ('\x004D', '\x0057') 42 | , ('\x004E', '\x1D0E') 43 | , ('\x0050', '\x0500') 44 | , ('\x0051', '\x038C') 45 | , ('\x0052', '\x1D1A') 46 | , ('\x0054', '\x22A5') 47 | , ('\x0055', '\x2229') 48 | , ('\x0056', '\x1D27') 49 | , ('\x0059', '\x2144') 50 | , ('\x005B', '\x005D') 51 | , ('\x005F', '\x203E') 52 | , ('\x0061', '\x0250') 53 | , ('\x0062', '\x0071') 54 | , ('\x0063', '\x0254') 55 | , ('\x0064', '\x0070') 56 | , ('\x0065', '\x01DD') 57 | , ('\x0066', '\x025F') 58 | , ('\x0067', '\x0183') 59 | , ('\x0068', '\x0265') 60 | , ('\x0069', '\x0131') 61 | , ('\x006A', '\x027E') 62 | , ('\x006B', '\x029E') 63 | , ('\x006C', '\x0283') 64 | , ('\x006D', '\x026F') 65 | , ('\x006E', '\x0075') 66 | , ('\x0072', '\x0279') 67 | , ('\x0074', '\x0287') 68 | , ('\x0076', '\x028C') 69 | , ('\x0077', '\x028D') 70 | , ('\x0079', '\x028E') 71 | , ('\x007B', '\x007D') 72 | , ('\x203F', '\x2040') 73 | , ('\x2045', '\x2046') 74 | , ('\x2234', '\x2235') 75 | , ('╰', '╭') 76 | , ('°', '｡') 77 | , ('︵', '︶') 78 | , ('⢀', '⠁') 79 | , ('⠠', '⠂') 80 | , ('⢠', '⠃') 81 | , ('⠐', '⠄') 82 | , ('⢐', '⠅') 83 | , ('⠰', '⠆') 84 | , ('⢰', '⠇') 85 | , ('⡀', '⠈') 86 | , ('⣀', '⠉') 87 | , ('⡠', '⠊') 88 | , ('⣠', '⠋') 89 | , ('⡐', '⠌') 90 | , ('⣐', '⠍') 91 | , ('⡰', '⠎') 92 | , ('⣰', '⠏') 93 | , ('⢄', '⠑') 94 | , ('⠤', '⠒') 95 | , ('⢤', '⠓') 96 | , ('⢔', '⠕') 97 | , ('⠴', '⠖') 98 | , ('⢴', '⠗') 99 | , ('⡄', '⠘') 100 | , ('⣄', '⠙') 101 | , ('⡤', '⠚') 102 | , ('⣤', '⠛') 103 | , ('⡔', '⠜') 104 | , ('⣔', '⠝') 105 | , ('⡴', '⠞') 106 | , ('⣴', '⠟') 107 | , ('⢂', '⠡') 108 | , ('⢢', '⠣') 109 | , ('⢒', '⠥') 110 | , ('⠲', '⠦') 111 | , ('⢲', '⠧') 112 | , ('⡂', '⠨') 113 | , ('⣂', '⠩') 114 | , ('⡢', '⠪') 115 | , ('⣢', '⠫') 116 | , ('⡒', '⠬') 117 | , ('⣒', '⠭') 118 | , ('⡲', '⠮') 119 | , ('⣲', '⠯') 120 | , ('⢆', '⠱') 121 | , ('⢦', '⠳') 122 | , ('⢖', '⠵') 123 | , ('⢶', '⠷') 124 | , ('⡆', '⠸') 125 | , ('⣆', '⠹') 126 | , ('⡦', '⠺') 127 | , ('⣦', '⠻') 128 | , ('⡖', '⠼') 129 | , ('⣖', '⠽') 130 | , ('⡶', '⠾') 131 | , ('⣶', '⠿') 132 | , ('⢈', '⡁') 133 | , ('⢨', '⡃') 134 | , ('⢘', '⡅') 135 | , ('⢸', '⡇') 136 | , ('⣈', '⡉') 137 | , ('⡨', '⡊') 138 | , ('⣨', '⡋') 139 | , ('⡘', '⡌') 140 | , ('⣘', '⡍') 141 | , ('⡸', '⡎') 142 | , ('⣸', '⡏') 143 | , ('⢌', '⡑') 144 | , ('⢬', '⡓') 145 | , ('⢜', '⡕') 146 | , ('⢼', '⡗') 147 | , ('⣌', '⡙') 148 | , ('⡬', '⡚') 149 | , ('⣬', '⡛') 150 | , ('⣜', '⡝') 151 | , ('⡼', '⡞') 152 | , ('⣼', '⡟') 153 | , ('⢊', '⡡') 154 | , ('⢪', '⡣') 155 | , ('⢚', '⡥') 156 | , ('⢺', '⡧') 157 | , ('⣊', '⡩') 158 | , ('⣪', '⡫') 159 | , ('⣚', '⡭') 160 | , ('⡺', '⡮') 161 | , ('⣺', '⡯') 162 | , ('⢎', '⡱') 163 | , ('⢮', '⡳') 164 | , ('⢞', '⡵') 165 | , ('⢾', '⡷') 166 | , ('⣎', '⡹') 167 | , ('⣮', '⡻') 168 | , ('⣞', '⡽') 169 | , ('⣾', '⡿') 170 | , ('⢡', '⢃') 171 | , ('⢑', '⢅') 172 | , ('⢱', '⢇') 173 | , ('⣁', '⢉') 174 | , ('⣡', '⢋') 175 | , ('⣑', '⢍') 176 | , ('⣱', '⢏') 177 | , ('⢥', '⢓') 178 | , ('⢵', '⢗') 179 | , ('⣅', '⢙') 180 | , ('⣥', '⢛') 181 | , ('⣕', '⢝') 182 | , ('⣵', '⢟') 183 | , ('⢳', '⢧') 184 | , ('⣃', '⢩') 185 | , ('⣣', '⢫') 186 | , ('⣓', '⢭') 187 | , ('⣳', '⢯') 188 | , ('⣇', '⢹') 189 | , ('⣧', '⢻') 190 | , ('⣗', '⢽') 191 | , ('⣷', '⢿') 192 | , ('⣩', '⣋') 193 | , ('⣙', '⣍') 194 | , ('⣹', '⣏') 195 | , ('⣭', '⣛') 196 | , ('⣽', '⣟') 197 | , ('⣻', '⣯') 198 | ] 199 | 200 | table1 :: M.Map Char Char 201 | table1 = M.fromList separateVariable 202 | 203 | table2 :: M.Map Char Char 204 | table2 = M.fromList $ map swap separateVariable 205 | -------------------------------------------------------------------------------- /src/KGBotka/Friday.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TupleSections #-} 4 | 5 | module KGBotka.Friday 6 | ( submitVideo 7 | , FridayVideo(..) 8 | , nextVideo 9 | , fridayVideoAsMessage 10 | , AuthorId(..) 11 | , fetchAllQueues 12 | , ytLinkId 13 | ) where 14 | 15 | import Control.Applicative 16 | import Control.Monad.Trans.Class 17 | import Control.Monad.Trans.Extra 18 | import Control.Monad.Trans.Maybe 19 | import Data.Array 20 | import qualified Data.Map as M 21 | import Data.Maybe 22 | import Data.String 23 | import qualified Data.Text as T 24 | import Data.Time 25 | import Database.SQLite.Simple 26 | import Database.SQLite.Simple.FromField 27 | import Database.SQLite.Simple.QQ 28 | import Database.SQLite.Simple.ToField 29 | import qualified Text.Regex.Base.RegexLike as Regex 30 | import qualified Text.Regex.TDFA.String as Regex 31 | 32 | newtype AuthorId = 33 | AuthorId T.Text 34 | deriving (Eq, Ord, Show) 35 | 36 | instance FromField AuthorId where 37 | fromField x = AuthorId <$> fromField x 38 | 39 | instance FromRow AuthorId where 40 | fromRow = AuthorId <$> field 41 | 42 | instance ToField AuthorId where 43 | toField (AuthorId x) = toField x 44 | 45 | instance IsString AuthorId where 46 | fromString = AuthorId . T.pack 47 | 48 | data FridayVideo = FridayVideo 49 | { fridayVideoId :: Int 50 | , fridayVideoSubText :: T.Text 51 | , fridayVideoSubTime :: UTCTime 52 | , fridayVideoAuthorId :: AuthorId 53 | , fridayVideoAuthorDisplayName :: T.Text 54 | , fridayVideoWatchedAt :: Maybe UTCTime 55 | } deriving (Show) 56 | 57 | instance FromRow FridayVideo where 58 | fromRow = 59 | FridayVideo <$> field <*> field <*> field <*> field <*> field <*> field 60 | 61 | submitVideo :: Connection -> T.Text -> AuthorId -> T.Text -> IO () 62 | submitVideo conn subText authorId authorDisplayName = 63 | executeNamed 64 | conn 65 | [sql| INSERT INTO FridayVideo 66 | (submissionText, submissionTime, authorId, authorDisplayName) 67 | VALUES 68 | (:submissionText, datetime('now'), :authorId, :authorDisplayName) |] 69 | [ ":submissionText" := subText 70 | , ":authorId" := authorId 71 | , ":authorDisplayName" := authorDisplayName 72 | ] 73 | 74 | fetchQueueByAuthorId :: Connection -> AuthorId -> IO [FridayVideo] 75 | fetchQueueByAuthorId dbConn authorId = 76 | queryNamed 77 | dbConn 78 | [sql|SELECT id, 79 | submissionText, 80 | submissionTime, 81 | authorId, 82 | authorDisplayName, 83 | watchedAt 84 | FROM FridayVideo 85 | WHERE watchedAt is NULL 86 | AND authorId = :authorId;|] 87 | [":authorId" := authorId] 88 | 89 | fetchAllQueues :: Connection -> IO [[FridayVideo]] 90 | fetchAllQueues dbConn = do 91 | authorIds <- 92 | queryNamed 93 | dbConn 94 | [sql|SELECT authorId 95 | FROM FridayVideo 96 | WHERE watchedAt is NULL 97 | GROUP BY authorId;|] 98 | [] 99 | mapM (fetchQueueByAuthorId dbConn) authorIds 100 | 101 | queueSlice :: Connection -> IO (M.Map AuthorId FridayVideo) 102 | queueSlice conn = 103 | M.fromList . map (\x -> (fridayVideoAuthorId x, x)) <$> 104 | queryNamed 105 | conn 106 | [sql|SELECT id, 107 | submissionText, 108 | min(submissionTime), 109 | authorId, 110 | authorDisplayName, 111 | watchedAt 112 | FROM FridayVideo 113 | WHERE watchedAt is NULL 114 | GROUP BY authorId|] 115 | [] 116 | 117 | lastWatchedAuthor :: Connection -> MaybeT IO AuthorId 118 | lastWatchedAuthor conn = 119 | MaybeT 120 | (listToMaybe <$> 121 | queryNamed 122 | conn 123 | [sql| SELECT authorId FROM FridayVideo 124 | WHERE watchedAt IS NOT NULL 125 | ORDER BY watchedAt DESC 126 | LIMIT 1 |] 127 | []) 128 | 129 | watchVideoById :: Connection -> Int -> IO () 130 | watchVideoById conn videoId = 131 | executeNamed 132 | conn 133 | [sql| UPDATE FridayVideo 134 | SET watchedAt = datetime('now') 135 | WHERE id = :id |] 136 | [":id" := videoId] 137 | 138 | nextVideo :: Connection -> MaybeT IO FridayVideo 139 | nextVideo conn = do 140 | author <- lastWatchedAuthor conn <|> return "" 141 | slice <- lift $ queueSlice conn 142 | video <- 143 | hoistMaybe (snd <$> M.lookupGT author slice) <|> 144 | hoistMaybe (snd <$> M.lookupGT "" slice) 145 | lift $ watchVideoById conn $ fridayVideoId video 146 | return video 147 | 148 | fridayVideoAsMessage :: FridayVideo -> T.Text 149 | fridayVideoAsMessage FridayVideo { fridayVideoSubText = subText 150 | , fridayVideoSubTime = subTime 151 | , fridayVideoAuthorDisplayName = authorDisplayName 152 | } = 153 | T.pack (show subTime) <> " <" <> authorDisplayName <> "> " <> subText 154 | 155 | ytLinkRegex :: Either String Regex.Regex 156 | ytLinkRegex = 157 | Regex.compile 158 | Regex.defaultCompOpt 159 | Regex.defaultExecOpt 160 | "https?:\\/\\/(www\\.)?youtu(be\\.com\\/watch\\?v=|\\.be\\/)([a-zA-Z0-9_-]+)" 161 | 162 | mapLeft :: (a -> c) -> Either a b -> Either c b 163 | mapLeft f (Left x) = Left (f x) 164 | mapLeft _ (Right x) = Right x 165 | 166 | -- | Extracts YouTube Video ID from the string 167 | -- Results: 168 | -- - `Right ytId` - extracted successfully 169 | -- - `Left (Just failReason)` - extraction failed because of 170 | -- the application's fault. The reason explained in `failReason`. 171 | -- `failReason` should be logged and later investigated by the devs. 172 | -- `failReason` should not be shown to the users. 173 | -- - `Left Nothing` - extraction failed because of the user's fault. 174 | -- Tell the user that their message does not contain any YouTube 175 | -- links. 176 | ytLinkId :: T.Text -> Either (Maybe String) T.Text 177 | ytLinkId text = do 178 | regex <- mapLeft Just ytLinkRegex 179 | result <- mapLeft Just $ Regex.execute regex (T.unpack text) 180 | case result of 181 | Just matches -> 182 | case map (T.pack . flip Regex.extract (T.unpack text)) $ elems matches of 183 | [_, _, _, ytId] -> Right ytId 184 | _ -> 185 | Left $ 186 | Just 187 | "Matches were not captured correctly. \ 188 | \Most likely somebody changed the YouTube \ 189 | \link regular expression (`ytLinkRegex`) and didn't \ 190 | \update `ytLinkId` function to extract capture \ 191 | \groups correctly. ( =_=)" 192 | Nothing -> Left Nothing 193 | -------------------------------------------------------------------------------- /src/KGBotka/GithubThread.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module KGBotka.GithubThread 4 | ( githubThread 5 | , GithubThreadParams(..) 6 | ) where 7 | 8 | import Control.Concurrent 9 | import Control.Exception 10 | import Control.Monad.Trans.Class 11 | import Control.Monad.Trans.Maybe 12 | import Data.Aeson 13 | import Data.Functor 14 | import qualified Data.Text as T 15 | import Data.Text.Encoding 16 | import qualified Database.SQLite.Simple as Sqlite 17 | import KGBotka.Config 18 | import KGBotka.Friday 19 | import KGBotka.Log 20 | import KGBotka.Queue 21 | import KGBotka.Settings 22 | import Network.HTTP.Client 23 | import Text.Printf 24 | 25 | data GithubThreadParams = GithubThreadParams 26 | { gtpSqliteConnection :: !(MVar Sqlite.Connection) 27 | , gtpManager :: !Manager 28 | , gtpLogQueue :: !(WriteQueue LogEntry) 29 | , gtpConfig :: !(Maybe ConfigGithub) 30 | , gtpUpdateRequired :: MVar () 31 | } 32 | 33 | instance ProvidesLogging GithubThreadParams where 34 | logEntry gtp = logEntry $ gtpLogQueue gtp 35 | 36 | data GithubThreadState = GithubThreadState 37 | { gtsSqliteConnection :: !(MVar Sqlite.Connection) 38 | , gtsManager :: !Manager 39 | , gtsLogQueue :: !(WriteQueue LogEntry) 40 | , gtsConfig :: ConfigGithub 41 | , gtsUpdateRequired :: MVar () 42 | } 43 | 44 | instance ProvidesLogging GithubThreadState where 45 | logEntry gts = logEntry $ gtsLogQueue gts 46 | 47 | githubThread :: GithubThreadParams -> IO () 48 | githubThread gtp@GithubThreadParams {gtpConfig = Just config} = 49 | githubThreadLoop 50 | GithubThreadState 51 | { gtsSqliteConnection = gtpSqliteConnection gtp 52 | , gtsManager = gtpManager gtp 53 | , gtsLogQueue = gtpLogQueue gtp 54 | , gtsConfig = config 55 | , gtsUpdateRequired = gtpUpdateRequired gtp 56 | } 57 | githubThread gtp = 58 | logEntry gtp $ 59 | LogEntry "GITHUB" "[ERROR] GitHub configuration is not provided" 60 | 61 | githubThreadLoop :: GithubThreadState -> IO () 62 | githubThreadLoop gts = do 63 | threadDelay $ 60 * 1000 * 1000 64 | takeMVar (gtsUpdateRequired gts) 65 | logEntry gts $ LogEntry "GITHUB" "Trying to update Friday Video Queue gist..." 66 | maybeFridayGistFile <- 67 | withMVar (gtsSqliteConnection gts) $ \conn -> 68 | Sqlite.withTransaction conn $ 69 | runMaybeT $ do 70 | gistId <- MaybeT (settingsFridayGithubGistId <$> fetchSettings conn) 71 | gistText <- lift $ renderAllQueues <$> fetchAllQueues conn 72 | return $ 73 | GistFile 74 | { gistFileId = gistId 75 | , gistFileText = gistText 76 | , gistFileName = "Friday.org" 77 | } 78 | case maybeFridayGistFile of 79 | Just fridayGistFile -> do 80 | logEntry gts $ LogEntry "GITHUB" "Updating Friday Video Queue gist..." 81 | updateGistFile 82 | gts 83 | (gtsManager gts) 84 | (configGithubToken $ gtsConfig gts) 85 | fridayGistFile 86 | Nothing -> 87 | logEntry gts $ 88 | LogEntry 89 | "GITHUB" 90 | "fridayGithubGistId is not set in the settings. Nothing to update." 91 | githubThreadLoop gts 92 | 93 | data GistFile = GistFile 94 | { gistFileId :: T.Text 95 | , gistFileName :: T.Text 96 | , gistFileText :: T.Text 97 | } 98 | 99 | updateGistFile :: 100 | ProvidesLogging log => log -> Manager -> GithubToken -> GistFile -> IO () 101 | updateGistFile logger manager (GithubToken token) gistFile = do 102 | let payload = 103 | object 104 | [ "files" .= 105 | object 106 | [ gistFileName gistFile .= 107 | object ["content" .= gistFileText gistFile] 108 | ] 109 | ] 110 | request <- 111 | parseRequest $ 112 | T.unpack $ "https://api.github.com/gists/" <> gistFileId gistFile 113 | catch 114 | (void $ 115 | httpLbs 116 | (request 117 | { method = "PATCH" 118 | , requestBody = RequestBodyLBS $ encode payload 119 | , requestHeaders = 120 | ("User-Agent", encodeUtf8 "KGBotka") : 121 | ("Authorization", encodeUtf8 $ "token " <> token) : 122 | requestHeaders request 123 | }) 124 | manager) 125 | (\e -> 126 | logEntry logger $ LogEntry "GITHUB" $ T.pack $ show (e :: SomeException)) 127 | return () 128 | 129 | renderFridayVideo :: FridayVideo -> T.Text 130 | renderFridayVideo video = 131 | T.pack $ 132 | printf 133 | "|%s|%s|%s|%s|" 134 | (show $ fridayVideoSubTime video) 135 | (fridayVideoAuthorDisplayName video) 136 | (fridayVideoSubText video) 137 | (either 138 | (const "") 139 | (\ytId -> "[[https://img.youtube.com/vi/" <> ytId <> "/default.jpg]]") $ 140 | ytLinkId $ fridayVideoSubText video) 141 | 142 | renderQueue :: [FridayVideo] -> T.Text 143 | renderQueue [] = "" 144 | renderQueue videos@(FridayVideo {fridayVideoAuthorDisplayName = name}:_) = 145 | T.unlines $ 146 | [ "** " <> name 147 | , "" 148 | , T.pack $ printf "Video Count: %d" $ length videos 149 | , "" 150 | , "|Date|Submitter|Video|Thumbnail|" 151 | , "|-" 152 | ] <> 153 | map renderFridayVideo videos <> 154 | [""] 155 | 156 | renderAllQueues :: [[FridayVideo]] -> T.Text 157 | renderAllQueues allQueues = header <> body 158 | where 159 | header :: T.Text 160 | header = 161 | T.unlines 162 | [ "* Friday Queue" 163 | , "" 164 | , "Use ~!friday~ command to put a video here (only for trusted and subs)." 165 | , "*Any video can be skipped if the streamer finds it boring.*" 166 | , "" 167 | ] 168 | body :: T.Text 169 | body = 170 | case allQueues of 171 | [] -> "No videos were submitted" 172 | _ -> T.concat (map renderQueue allQueues) 173 | -------------------------------------------------------------------------------- /src/KGBotka/JoinedTwitchChannels.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module KGBotka.JoinedTwitchChannels 5 | ( joinedChannels 6 | , registerJoinedChannel 7 | , unregisterJoinedChannel 8 | , callPrefixOfJoinedChannel 9 | , setPrefixOfJoinedChannel 10 | ) where 11 | 12 | import qualified Data.Text as T 13 | import qualified Database.SQLite.Simple as Sqlite 14 | import Database.SQLite.Simple (NamedParam(..)) 15 | import Database.SQLite.Simple.FromRow 16 | import Database.SQLite.Simple.QQ 17 | import KGBotka.TwitchAPI 18 | 19 | data JoinedTwitchChannel = JoinedTwitchChannel 20 | { joinedChannelTwitchChannel :: TwitchIrcChannel 21 | , joinedChannelCallPrefix :: T.Text 22 | } 23 | 24 | instance FromRow JoinedTwitchChannel where 25 | fromRow = JoinedTwitchChannel <$> field <*> field 26 | 27 | joinedChannels :: Sqlite.Connection -> IO [TwitchIrcChannel] 28 | joinedChannels dbConn = do 29 | channels <- 30 | Sqlite.queryNamed dbConn [sql|SELECT * FROM JoinedTwitchChannels;|] [] 31 | return $ map joinedChannelTwitchChannel channels 32 | 33 | registerJoinedChannel :: Sqlite.Connection -> TwitchIrcChannel -> IO () 34 | registerJoinedChannel dbConn channel = 35 | Sqlite.executeNamed 36 | dbConn 37 | [sql|INSERT INTO JoinedTwitchChannels (name) 38 | VALUES (:channel);|] 39 | [":channel" := channel] 40 | 41 | callPrefixOfJoinedChannel :: Sqlite.Connection -> TwitchIrcChannel -> IO T.Text 42 | callPrefixOfJoinedChannel dbConn channel = 43 | joinedChannelCallPrefix . head <$> 44 | Sqlite.queryNamed 45 | dbConn 46 | [sql|SELECT * FROM JoinedTwitchChannels WHERE name = :channel;|] 47 | [":channel" := channel] 48 | 49 | setPrefixOfJoinedChannel :: 50 | Sqlite.Connection -> TwitchIrcChannel -> T.Text -> IO () 51 | setPrefixOfJoinedChannel dbConn channel prefix = 52 | Sqlite.executeNamed 53 | dbConn 54 | [sql|UPDATE JoinedTwitchChannels SET channelCommandPrefix = :pref WHERE name = :channel;|] 55 | [":channel" := channel, ":pref" := prefix] 56 | 57 | unregisterJoinedChannel :: Sqlite.Connection -> TwitchIrcChannel -> IO () 58 | unregisterJoinedChannel dbConn channel = 59 | Sqlite.executeNamed 60 | dbConn 61 | [sql|DELETE FROM JoinedTwitchChannels 62 | WHERE name = :channel|] 63 | [":channel" := channel] 64 | -------------------------------------------------------------------------------- /src/KGBotka/Log.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module KGBotka.Log 4 | ( loggingThread 5 | , LogEntry(..) 6 | , ProvidesLogging(..) 7 | ) where 8 | 9 | import Control.Concurrent 10 | import Control.Concurrent.STM 11 | import qualified Data.Text as T 12 | import Data.Time 13 | import KGBotka.Queue 14 | import System.IO 15 | import Text.Printf 16 | 17 | -- NOTE: the Tag is use to indicate the "subsystem" where the event 18 | -- has happened. Examples are "TWITCH", "SQLITE", "ASCIIFY", etc. It 19 | -- is prefered to capitalize them. 20 | data LogEntry = LogEntry 21 | { logEntryTag :: T.Text 22 | , logEntryText :: T.Text 23 | } deriving (Eq, Show) 24 | 25 | loggingThread :: FilePath -> ReadQueue LogEntry -> IO () 26 | loggingThread logFilePath messageQueue = withFile logFilePath AppendMode loop 27 | where 28 | loop logHandle = do 29 | threadDelay 10000 -- to prevent busy looping 30 | messages <- atomically $ flushQueue messageQueue 31 | mapM_ (logEntry logHandle) messages 32 | hFlush logHandle 33 | loop logHandle 34 | 35 | class ProvidesLogging l where 36 | logEntry :: l -> LogEntry -> IO () 37 | 38 | instance ProvidesLogging (WriteQueue LogEntry) where 39 | logEntry logging = atomically . writeQueue logging 40 | 41 | instance ProvidesLogging Handle where 42 | logEntry handle (LogEntry tag text) = do 43 | now <- getCurrentTime 44 | let timestamp = 45 | formatTime defaultTimeLocale (iso8601DateFormat $ Just "%H:%M:%S") now 46 | hPrintf handle "[%s] [%s] %s\n" timestamp tag text 47 | -------------------------------------------------------------------------------- /src/KGBotka/Markov.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | 5 | module KGBotka.Markov 6 | ( genMarkovSentence 7 | , isDiscordPing 8 | , MarkovCommand(..) 9 | , MarkovThreadParams(..) 10 | , markovThread 11 | ) where 12 | 13 | import Control.Concurrent 14 | import Control.Concurrent.STM 15 | import Control.Exception 16 | import Control.Monad.Trans.Class 17 | import Control.Monad.Trans.Maybe 18 | import Data.Foldable 19 | import Data.Functor 20 | import Data.Maybe 21 | import qualified Data.Text as T 22 | import qualified Database.SQLite.Simple as Sqlite 23 | import Database.SQLite.Simple (NamedParam(..)) 24 | import Database.SQLite.Simple.FromField 25 | import Database.SQLite.Simple.QQ 26 | import Database.SQLite.Simple.ToField 27 | import KGBotka.Log 28 | import KGBotka.Queue 29 | import KGBotka.Sqlite 30 | import System.Random 31 | import Text.Regex.TDFA (defaultCompOpt, defaultExecOpt) 32 | import Text.Regex.TDFA.String 33 | 34 | -- TODO(#46): Markov does not split models by twitch channels 35 | -- TODO(#47): there is no way to retrain the model from the TwitchLog 36 | data Event 37 | = Begin 38 | | Word T.Text 39 | | End 40 | deriving (Eq, Read, Show, Ord) 41 | 42 | instance ToField Event where 43 | toField = toField . T.pack . show 44 | 45 | instance FromField Event where 46 | fromField = fmap (read . T.unpack) . fromField 47 | 48 | isDiscordPing :: T.Text -> Bool 49 | isDiscordPing text = 50 | either (const False) isJust $ do 51 | regex <- compile defaultCompOpt defaultExecOpt "<@!?[0-9]+>" 52 | execute regex (T.unpack text) 53 | 54 | addMarkovSentence :: Sqlite.Connection -> T.Text -> IO () 55 | addMarkovSentence conn sentence 56 | | T.length sentence >= 50 = 57 | mapM_ (addMarkovPair conn) $ 58 | scanPairs $ 59 | (\xs -> [Begin] <> xs <> [End]) $ 60 | map Word $ 61 | filter (not . isDiscordPing) $ T.words $ T.unwords $ T.words sentence 62 | | otherwise = return () 63 | 64 | addMarkovPair :: Sqlite.Connection -> (Event, Event) -> IO () 65 | addMarkovPair conn (event1, event2) = do 66 | n <- 67 | maybe (0 :: Int) Sqlite.fromOnly . listToMaybe <$> 68 | Sqlite.queryNamed 69 | conn 70 | "SELECT n FROM Markov WHERE event1 = :event1 AND event2 = :event2" 71 | [":event1" := event1, ":event2" := event2] 72 | Sqlite.executeNamed 73 | conn 74 | "INSERT INTO Markov (event1, event2, n) VALUES (:event1, :event2, :n)" 75 | [":event1" := event1, ":event2" := event2, ":n" := succ n] 76 | 77 | nextMarkovEvent :: Sqlite.Connection -> Event -> MaybeT IO Event 78 | nextMarkovEvent conn event1 = do 79 | bs <- 80 | lift $ 81 | Sqlite.queryNamed 82 | conn 83 | "SELECT event2, n FROM Markov WHERE event1 = :event1" 84 | [":event1" := event1] 85 | let n :: Int 86 | n = foldl' (+) 0 $ map snd bs 87 | i <- lift $ randomRIO (0, n - 1) 88 | let a = 89 | dropWhile (\x -> snd x < i) $ 90 | zip (map fst bs) $ scanl (+) 0 $ map snd bs 91 | case a of 92 | [] -> return End 93 | (event', _):_ -> return event' 94 | 95 | seqMarkovEvents :: Event -> Event -> Sqlite.Connection -> IO [Event] 96 | seqMarkovEvents begin end m 97 | | begin == end = return [end] 98 | | otherwise = do 99 | nxt <- runMaybeT $ nextMarkovEvent m begin 100 | case nxt of 101 | Just nxt' -> do 102 | rest <- seqMarkovEvents nxt' end m 103 | return (begin : rest) 104 | Nothing -> return [] 105 | 106 | scanPairs :: [a] -> [(a, a)] 107 | scanPairs xs = zip xs $ tail xs 108 | 109 | genMarkovSentence :: Sqlite.Connection -> Maybe T.Text -> IO T.Text 110 | genMarkovSentence dbConn seed = do 111 | events <- seqMarkovEvents (maybe Begin Word seed) End dbConn 112 | return $ 113 | T.unwords $ 114 | mapMaybe 115 | (\case 116 | Begin -> Nothing 117 | End -> Nothing 118 | Word x -> Just x) 119 | events 120 | 121 | data MarkovCommand 122 | = NewSentence T.Text 123 | | Retrain 124 | | StopRetrain 125 | 126 | data MarkovThreadParams = MarkovThreadParams 127 | { mtpSqliteConnection :: !(MVar Sqlite.Connection) 128 | , mtpLogQueue :: !(WriteQueue LogEntry) 129 | , mtpCmdQueue :: !(ReadQueue MarkovCommand) 130 | , mtpPageSize :: !Int 131 | , mtpRetrainProgress :: !(MVar (Maybe Int)) 132 | } 133 | 134 | withTransactionLogErrors :: 135 | MVar Sqlite.Connection 136 | -> WriteQueue LogEntry 137 | -> (Sqlite.Connection -> IO a) 138 | -> IO (Maybe a) 139 | withTransactionLogErrors dbConn lqueue f = 140 | catch 141 | (withLockedTransaction dbConn $ fmap Just . f) 142 | (\e -> do 143 | logEntry lqueue $ 144 | LogEntry "MARKOV" $ T.pack $ show (e :: Sqlite.SQLError) 145 | return Nothing) 146 | 147 | markovThread :: MarkovThreadParams -> IO () 148 | markovThread mtp@MarkovThreadParams { mtpSqliteConnection = dbConn 149 | , mtpLogQueue = lqueue 150 | , mtpCmdQueue = cmdQueue 151 | , mtpRetrainProgress = retrainProgress 152 | , mtpPageSize = pageSize 153 | } = do 154 | threadDelay 10000 -- to prevent busy looping 155 | modifyMVar_ retrainProgress $ \case 156 | Just progress -> do 157 | cmd <- atomically $ tryReadQueue cmdQueue 158 | case cmd of 159 | Just Retrain -> do 160 | void $ 161 | withTransactionLogErrors dbConn lqueue $ \conn -> 162 | Sqlite.executeNamed conn [sql|DELETE FROM Markov;|] [] 163 | return $ Just 0 164 | Just StopRetrain -> return Nothing 165 | _ 166 | -- TODO(#183): Markov retraining does not use Discord logs 167 | -> do 168 | processed <- 169 | withTransactionLogErrors dbConn lqueue $ \conn -> do 170 | messages <- 171 | Sqlite.queryNamed 172 | conn 173 | [sql| select message from TwitchLog 174 | order by id limit :pageSize 175 | offset :progress |] 176 | [":pageSize" := pageSize, ":progress" := progress] 177 | traverse_ (addMarkovSentence conn . Sqlite.fromOnly) messages 178 | return $ length messages 179 | case processed of 180 | Just x 181 | | x > 0 -> return $ Just $ progress + x 182 | Just _ -> return Nothing 183 | Nothing -> return $ Just progress 184 | Nothing -> do 185 | cmd <- atomically $ tryReadQueue cmdQueue 186 | case cmd of 187 | Just (NewSentence text) -> do 188 | void $ 189 | withTransactionLogErrors dbConn lqueue $ \conn -> 190 | addMarkovSentence conn text 191 | return Nothing 192 | Just Retrain -> do 193 | void $ 194 | withTransactionLogErrors dbConn lqueue $ \conn -> 195 | Sqlite.executeNamed conn [sql|DELETE FROM Markov;|] [] 196 | return $ Just 0 197 | Just StopRetrain -> return Nothing 198 | Nothing -> return Nothing 199 | markovThread mtp 200 | -------------------------------------------------------------------------------- /src/KGBotka/Migration.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module KGBotka.Migration 5 | ( migrateDatabase 6 | , Migration(..) 7 | , kgbotkaMigrations 8 | ) where 9 | 10 | import Data.String 11 | 12 | import Data.Foldable 13 | import Database.SQLite.Simple 14 | import Database.SQLite.Simple.QQ 15 | import Database.SQLite3 16 | 17 | newtype Migration = Migration 18 | { migrationQuery :: Query 19 | } deriving (Show) 20 | 21 | instance IsString Migration where 22 | fromString = Migration . fromString 23 | 24 | instance FromRow Migration where 25 | fromRow = fromString <$> field 26 | 27 | applyMigration :: Connection -> Migration -> IO () 28 | applyMigration conn (Migration q) = do 29 | execute_ conn q 30 | executeNamed 31 | conn 32 | "INSERT INTO Migrations (migrationQuery)\ 33 | \VALUES (:migrationQuery)" 34 | [":migrationQuery" := fromQuery q] 35 | 36 | createMigrationTablesIfNeeded :: Connection -> IO () 37 | createMigrationTablesIfNeeded conn = 38 | execute_ 39 | conn 40 | "CREATE TABLE IF NOT EXISTS Migrations (\ 41 | \ id INTEGER PRIMARY KEY, \ 42 | \ migrationQuery TEXT NOT NULL \ 43 | \)" 44 | 45 | stripPrefixM :: Monad m => (a -> a -> m Bool) -> [a] -> [a] -> m (Maybe [a]) 46 | stripPrefixM _ [] ys = return $ Just ys 47 | stripPrefixM predicate (x:xs) (y:ys) = do 48 | cond <- predicate x y 49 | if cond 50 | then stripPrefixM predicate xs ys 51 | else return Nothing 52 | stripPrefixM _ _ _ = return Nothing 53 | 54 | filterUnappliedMigrations :: Connection -> [Migration] -> IO [Migration] 55 | filterUnappliedMigrations conn migrations = do 56 | appliedMigrations <- query_ conn "SELECT migrationQuery FROM Migrations" 57 | unappliedMigrations <- 58 | stripPrefixM 59 | (\x y -> 60 | queriesIdentical 61 | (fromQuery $ migrationQuery x) 62 | (fromQuery $ migrationQuery y)) 63 | appliedMigrations 64 | migrations 65 | case unappliedMigrations of 66 | Just x -> return x 67 | Nothing -> 68 | error 69 | "Inconsistent migrations state! \ 70 | \List of already applied migrations \ 71 | \is not a prefix of required migrations." 72 | 73 | migrateDatabase :: Connection -> [Migration] -> IO () 74 | migrateDatabase conn migrations = do 75 | createMigrationTablesIfNeeded conn 76 | unappliedMigrations <- filterUnappliedMigrations conn migrations 77 | traverse_ (applyMigration conn) unappliedMigrations 78 | 79 | kgbotkaMigrations :: [Migration] 80 | kgbotkaMigrations = 81 | [ Migration 82 | [sql|CREATE TABLE Command ( 83 | id INTEGER PRIMARY KEY, 84 | code TEXT NOT NULL 85 | );|] 86 | , Migration 87 | [sql|CREATE TABLE CommandName ( 88 | name TEXT NOT NULL, 89 | commandId INTEGER NOT NULL REFERENCES Command(id) ON DELETE CASCADE, 90 | UNIQUE(name) ON CONFLICT REPLACE 91 | );|] 92 | , Migration 93 | [sql|CREATE TABLE TwitchRoles ( 94 | id INTEGER PRIMARY KEY, 95 | name TEXT NOT NULL UNIQUE 96 | );|] 97 | , Migration 98 | [sql|CREATE TABLE TwitchUserRoles ( 99 | userId TEXT NOT NULL, 100 | roleId INTEGER NOT NULL REFERENCES TwitchRoles(id) ON DELETE CASCADE, 101 | UNIQUE(userId, roleId) ON CONFLICT IGNORE 102 | );|] 103 | -- TODO(#126): There is no way to find out from where the video was submitted (Twitch or Discord) based on the data from FridayVideo 104 | , Migration 105 | [sql|CREATE TABLE FridayVideo ( 106 | id INTEGER PRIMARY KEY, 107 | submissionText TEXT NOT NULL, 108 | submissionTime DATETIME NOT NULL, 109 | authorId TEXT NOT NULL, 110 | authorDisplayName TEXT NOT NULL, 111 | watchedAt DATETIME 112 | );|] 113 | , Migration 114 | [sql|CREATE TABLE TwitchLog ( 115 | id INTEGER PRIMARY KEY, 116 | channel TEXT NOT NULL, 117 | senderTwitchId TEXT NOT NULL, 118 | senderTwitchName TEXT NOT NULL, 119 | senderTwitchDisplayName TEXT, 120 | senderTwitchRoles TEXT NOT NULL, 121 | senderTwitchBadgeRoles TEXT NOT NULL, 122 | message TEXT NOT NULL, 123 | messageTime DATETIME DEFAULT (datetime('now')) NOT NULL 124 | )|] 125 | , Migration 126 | [sql|CREATE TABLE Markov ( 127 | event1 TEXT NOT NULL, 128 | event2 TEXT NOT NULL, 129 | n INTEGER NOT NULL, 130 | UNIQUE (event1, event2) ON CONFLICT REPLACE 131 | ); 132 | CREATE INDEX markov_event1_index ON Markov (event1);|] 133 | , Migration 134 | [sql|ALTER TABLE Command 135 | ADD COLUMN user_cooldown_ms INTEGER NOT NULL DEFAULT 0;|] 136 | , Migration 137 | [sql|CREATE TABLE CommandLog ( 138 | userTwitchId TEXT, 139 | userDiscordId TEXT, 140 | commandId INTEGER NOT NULL, 141 | commandArgs TEXT NOT NULL, 142 | timestamp DATETIME NOT NULL DEFAULT CURRENT_TIMESTAMP 143 | );|] 144 | , Migration 145 | [sql|CREATE TABLE AsciifyUrlCache( 146 | url TEXT NOT NULL, 147 | image TEXT NOT NULL, 148 | UNIQUE (url) ON CONFLICT REPLACE 149 | );|] 150 | , Migration 151 | [sql|CREATE TABLE BttvEmotes ( 152 | name TEXT NOT NULL, 153 | channel TEXT DEFAULT NULL, 154 | imageUrl TEXT NOT NULL 155 | );|] 156 | , Migration 157 | [sql|CREATE TABLE FfzEmotes ( 158 | name TEXT NOT NULL, 159 | channel TEXT DEFAULT NULL, 160 | imageUrl TEXT NOT NULL 161 | );|] 162 | , Migration 163 | [sql|CREATE TABLE DiscordLog ( 164 | id INTEGER PRIMARY KEY, 165 | guildId TEXT, 166 | channelId TEXT NOT NULL, 167 | senderDiscordId TEXT NOT NULL, 168 | message TEXT NOT NULL, 169 | messageTime DATETIME DEFAULT (datetime('now')) NOT NULL 170 | )|] 171 | , Migration 172 | [sql|CREATE TABLE Settings ( 173 | name TEXT NOT NULL, 174 | value TEXT NOT NULL 175 | )|] 176 | , Migration 177 | [sql|CREATE TABLE JoinedTwitchChannels ( 178 | name TEXT NOT NULL, 179 | UNIQUE (name) ON CONFLICT IGNORE 180 | )|] 181 | , Migration 182 | [sql|ALTER TABLE Command 183 | ADD COLUMN times INT NOT NULL DEFAULT 0;|] 184 | , Migration [sql|ALTER TABLE TwitchLog RENAME TO TwitchLogOld;|] 185 | , Migration 186 | [sql|CREATE TABLE TwitchLog ( 187 | id INTEGER PRIMARY KEY, 188 | channel TEXT NOT NULL, 189 | senderTwitchId TEXT, 190 | senderTwitchName TEXT NOT NULL, 191 | senderTwitchDisplayName TEXT, 192 | senderTwitchRoles TEXT NOT NULL, 193 | senderTwitchBadgeRoles TEXT NOT NULL, 194 | message TEXT NOT NULL, 195 | messageTime DATETIME DEFAULT (datetime('now')) NOT NULL);|] 196 | , Migration 197 | [sql|INSERT INTO TwitchLog (id, channel, senderTwitchId, senderTwitchName, senderTwitchDisplayName, senderTwitchRoles, senderTwitchBadgeRoles, message, messageTime) SELECT id, channel, senderTwitchId, senderTwitchName, senderTwitchDisplayName, senderTwitchRoles, senderTwitchBadgeRoles, message, messageTime FROM TwitchLogOld;|] 198 | , Migration [sql|DROP TABLE TwitchLogOld;|] 199 | , Migration [sql|ALTER TABLE DiscordLog RENAME TO DiscordLogOld;|] 200 | , Migration 201 | [sql|CREATE TABLE DiscordLog ( 202 | id INTEGER PRIMARY KEY, 203 | guildId TEXT, 204 | channelId TEXT NOT NULL, 205 | senderDiscordId TEXT, 206 | senderDiscordDisplayName TEXT, 207 | message TEXT NOT NULL, 208 | messageTime DATETIME DEFAULT (datetime('now')) NOT NULL 209 | );|] 210 | , Migration 211 | [sql|INSERT INTO DiscordLog (id, guildId, channelId, senderDiscordId, senderDiscordDisplayName, message, messageTime) SELECT id, guildId, channelId, senderDiscordId, NULL, message, messageTime FROM DiscordLogOld;|] 212 | , Migration [sql|DROP TABLE DiscordLogOld;|] 213 | , Migration 214 | [sql|CREATE TABLE RoleEmojiAssoc ( 215 | emojiId TEXT NOT NULL, 216 | roleId INTEGER NOT NULL, 217 | msgId INTEGER NOT NULL, 218 | UNIQUE(emojiId, msgId) 219 | );|] 220 | , Migration 221 | [sql|ALTER TABLE Command ADD COLUMN argsRegex TEXT NOT NULL DEFAULT '(.*)';|] 222 | , Migration 223 | [sql|CREATE TABLE xkcd ( 224 | num INTEGER UNIQUE, 225 | title TEXT, 226 | img TEXT, 227 | alt TEXT, 228 | transcript TEXT 229 | );|] 230 | , Migration 231 | [sql|CREATE TABLE IF NOT EXISTS xkcd_tf_idf ( 232 | term TEXT, 233 | freq INTEGER, 234 | num INTEGER 235 | );|] 236 | , Migration 237 | [sql|ALTER TABLE JoinedTwitchChannels ADD COLUMN channelCommandPrefix TEXT NOT NULL DEFAULT '!';|] 238 | ] 239 | -------------------------------------------------------------------------------- /src/KGBotka/Monitor.hs: -------------------------------------------------------------------------------- 1 | module KGBotka.Monitor where 2 | 3 | import Control.Concurrent 4 | 5 | -- Who needs OCaml LOOOOOOL 6 | newtype T = 7 | T (MVar ()) 8 | 9 | new :: IO T 10 | new = T <$> newEmptyMVar 11 | 12 | wait :: T -> IO () 13 | wait (T mvar) = takeMVar mvar 14 | 15 | notify :: T -> IO () 16 | notify (T mvar) = putMVar mvar () 17 | -------------------------------------------------------------------------------- /src/KGBotka/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | 4 | module KGBotka.Parser where 5 | 6 | import Control.Applicative 7 | import Control.Monad 8 | import qualified Data.Text as T 9 | import Data.Tuple 10 | 11 | data ParserStop 12 | = EOF 13 | | SyntaxError T.Text 14 | deriving (Eq, Show) 15 | 16 | newtype Parser a = Parser 17 | { runParser :: T.Text -> Either ParserStop (T.Text, a) 18 | } deriving (Functor) 19 | 20 | instance Applicative Parser where 21 | pure x = Parser $ \text -> Right (text, x) 22 | (Parser f) <*> (Parser x) = 23 | Parser $ \input1 -> do 24 | (input2, f') <- f input1 25 | (input3, x') <- x input2 26 | return (input3, f' x') 27 | 28 | instance Monad Parser where 29 | Parser a >>= f = 30 | Parser $ \input1 -> do 31 | (input2, b) <- a input1 32 | runParser (f b) input2 33 | 34 | instance Alternative Parser where 35 | empty = Parser $ const $ Left EOF 36 | (Parser p1) <|> (Parser p2) = 37 | Parser $ \input -> 38 | case (p1 input, p2 input) of 39 | (Left _, x) -> x 40 | (x, _) -> x 41 | 42 | ws :: Parser () 43 | ws = void $ takeWhileP $ flip elem (" \t\n\r" :: String) 44 | 45 | sepBy :: Parser a -> Parser b -> Parser [a] 46 | sepBy element sep = do 47 | arg <- element 48 | args <- many (sep >> element) 49 | return (arg : args) 50 | 51 | takeWhileP :: (Char -> Bool) -> Parser T.Text 52 | takeWhileP p = Parser $ \input -> return $ swap $ T.span p input 53 | 54 | charP :: Char -> Parser Char 55 | charP a = 56 | Parser $ \input -> 57 | case T.uncons input of 58 | Just (b, rest) 59 | | a == b -> Right (rest, b) 60 | _ -> Left $ SyntaxError ("Expected `" <> T.pack [a] <> "`") 61 | 62 | notNull :: T.Text -> Parser T.Text -> Parser T.Text 63 | notNull message next = 64 | next >>= 65 | (\value -> 66 | if T.null value 67 | then syntaxError message 68 | else return value) 69 | 70 | inParens :: Parser a -> Parser a 71 | inParens p = charP '(' *> p <* charP ')' 72 | 73 | syntaxError :: T.Text -> Parser a 74 | syntaxError message = Parser $ \_ -> Left $ SyntaxError message 75 | 76 | eof :: Parser () 77 | eof = 78 | Parser $ \input -> 79 | case T.unpack input of 80 | [] -> Right (mempty, ()) 81 | _ -> Left $ SyntaxError "Expected EOF" 82 | -------------------------------------------------------------------------------- /src/KGBotka/Queue.hs: -------------------------------------------------------------------------------- 1 | module KGBotka.Queue 2 | ( WriteQueue(..) 3 | , writeQueue 4 | , ReadQueue(..) 5 | , readQueue 6 | , tryReadQueue 7 | , toWriteQueue 8 | , toReadQueue 9 | , flushQueue 10 | ) where 11 | 12 | import Control.Concurrent.STM 13 | 14 | newtype WriteQueue a = WriteQueue 15 | { getWriteQueue :: TQueue a 16 | } 17 | 18 | {-# INLINE writeQueue #-} 19 | writeQueue :: WriteQueue a -> a -> STM () 20 | writeQueue = writeTQueue . getWriteQueue 21 | 22 | newtype ReadQueue a = ReadQueue 23 | { getReadQueue :: TQueue a 24 | } 25 | 26 | {-# INLINE readQueue #-} 27 | readQueue :: ReadQueue a -> STM a 28 | readQueue = readTQueue . getReadQueue 29 | 30 | {-# INLINE tryReadQueue #-} 31 | tryReadQueue :: ReadQueue a -> STM (Maybe a) 32 | tryReadQueue = tryReadTQueue . getReadQueue 33 | 34 | {-# INLINE flushQueue #-} 35 | flushQueue :: ReadQueue a -> STM [a] 36 | flushQueue = flushTQueue . getReadQueue 37 | 38 | {-# INLINE toWriteQueue #-} 39 | toWriteQueue :: ReadQueue a -> WriteQueue a 40 | toWriteQueue = WriteQueue . getReadQueue 41 | 42 | {-# INLINE toReadQueue #-} 43 | toReadQueue :: WriteQueue a -> ReadQueue a 44 | toReadQueue = ReadQueue . getWriteQueue 45 | -------------------------------------------------------------------------------- /src/KGBotka/Repl.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | 5 | module KGBotka.Repl 6 | ( backdoorThread 7 | , ReplCommand(..) 8 | , BackdoorThreadParams(..) 9 | ) where 10 | 11 | import Control.Concurrent 12 | import Control.Concurrent.STM 13 | import Control.Exception 14 | import Control.Monad 15 | import Control.Monad.Trans.Eval 16 | import Control.Monad.Trans.Except 17 | import Control.Monad.Trans.State.Strict 18 | import qualified Data.ByteString as BS 19 | import qualified Data.ByteString.Base64 as BS 20 | import Data.Foldable 21 | import qualified Data.Map as M 22 | import Data.Maybe 23 | import qualified Data.Text as T 24 | import qualified Data.Text.Encoding as T 25 | import qualified Database.SQLite.Simple as Sqlite 26 | import Database.SQLite.Simple.QQ 27 | import KGBotka.Bttv 28 | import KGBotka.Command 29 | import KGBotka.Config 30 | import KGBotka.Eval 31 | import KGBotka.Expr 32 | import KGBotka.Ffz 33 | import KGBotka.JoinedTwitchChannels 34 | import KGBotka.Log 35 | import KGBotka.Markov 36 | import qualified KGBotka.Monitor as Monitor 37 | import KGBotka.Parser 38 | import KGBotka.Queue 39 | import KGBotka.Roles 40 | import KGBotka.Sqlite 41 | import KGBotka.TwitchAPI 42 | import qualified Network.HTTP.Client as HTTP 43 | import Network.Socket 44 | import System.IO 45 | import System.Random 46 | import Text.Printf 47 | 48 | data ReplThreadParams = ReplThreadParams 49 | { rtpSqliteConnection :: !(MVar Sqlite.Connection) 50 | , rtpCommandQueue :: !(WriteQueue ReplCommand) 51 | , rtpConfigTwitch :: !(Maybe ConfigTwitch) 52 | , rtpExitMonitor :: !Monitor.T 53 | , rtpManager :: !HTTP.Manager 54 | , rtpHandle :: !Handle 55 | , rtpLogQueue :: !(WriteQueue LogEntry) 56 | , rtpConnAddr :: !SockAddr 57 | , rtpMarkovQueue :: !(WriteQueue MarkovCommand) 58 | , rtpRetrainProgress :: !(MVar (Maybe Int)) 59 | , rtpFridayGistUpdateRequired :: !(MVar ()) 60 | } 61 | 62 | instance ProvidesLogging ReplThreadParams where 63 | logEntry rtp = logEntry $ rtpLogQueue rtp 64 | 65 | data ReplThreadState = ReplThreadState 66 | { rtsSqliteConnection :: !(MVar Sqlite.Connection) 67 | , rtsCurrentChannel :: !(Maybe TwitchIrcChannel) 68 | , rtsCommandQueue :: !(WriteQueue ReplCommand) 69 | , rtsExitMonitor :: !Monitor.T 70 | , rtsConfigTwitch :: !(Maybe ConfigTwitch) 71 | , rtsManager :: !HTTP.Manager 72 | , rtsHandle :: !Handle 73 | , rtsLogQueue :: !(WriteQueue LogEntry) 74 | , rtsConnAddr :: !SockAddr 75 | , rtsMarkovQueue :: !(WriteQueue MarkovCommand) 76 | , rtsRetrainProgress :: !(MVar (Maybe Int)) 77 | , rtsFridayGistUpdateRequired :: !(MVar ()) 78 | } 79 | 80 | data ReplCommand 81 | = Say TwitchIrcChannel 82 | T.Text 83 | | JoinChannel TwitchIrcChannel 84 | | PartChannel TwitchIrcChannel 85 | 86 | replThread :: ReplThreadParams -> IO () 87 | replThread rtp = 88 | replThreadLoop 89 | ReplThreadState 90 | { rtsSqliteConnection = rtpSqliteConnection rtp 91 | , rtsCurrentChannel = Nothing 92 | , rtsCommandQueue = rtpCommandQueue rtp 93 | , rtsConfigTwitch = rtpConfigTwitch rtp 94 | , rtsExitMonitor = rtpExitMonitor rtp 95 | , rtsManager = rtpManager rtp 96 | , rtsHandle = rtpHandle rtp 97 | , rtsLogQueue = rtpLogQueue rtp 98 | , rtsConnAddr = rtpConnAddr rtp 99 | , rtsMarkovQueue = rtpMarkovQueue rtp 100 | , rtsRetrainProgress = rtpRetrainProgress rtp 101 | , rtsFridayGistUpdateRequired = rtpFridayGistUpdateRequired rtp 102 | } 103 | 104 | replPutStr :: Handle -> T.Text -> IO () 105 | replPutStr h = BS.hPutStr h . T.encodeUtf8 106 | 107 | replPutStrLn :: Handle -> T.Text -> IO () 108 | replPutStrLn h text = replPutStr h $ text <> "\n" 109 | 110 | -- TODO(#60): there is no shutdown command that shuts down the whole bot 111 | -- Since we introduce backdoor connections the quit command does 112 | -- not serve such purpose anymore, 'cause it only closes the current 113 | -- REPL connection 114 | -- TODO(#65): there is no `who` command that would show all of the Backdoor connections 115 | replThreadLoop :: ReplThreadState -> IO () 116 | replThreadLoop rts = do 117 | let replHandle = rtsHandle rts 118 | let withTransactionLogErrors :: (Sqlite.Connection -> IO ()) -> IO () 119 | withTransactionLogErrors f = 120 | catch 121 | (withLockedTransaction (rtsSqliteConnection rts) f) 122 | (\e -> hPrint replHandle (e :: Sqlite.SQLError)) 123 | replPutStr replHandle $ 124 | "[" <> twitchIrcChannelText (fromMaybe "#" $ rtsCurrentChannel rts) <> "]> " 125 | hFlush (rtsHandle rts) 126 | inputLine <- T.decodeUtf8 <$> BS.hGetLine replHandle 127 | atomically $ 128 | writeQueue (rtsLogQueue rts) $ 129 | LogEntry "BACKDOOR" $ T.pack (show $ rtsConnAddr rts) <> ": " <> inputLine 130 | case ( T.dropWhile (== ' ') <$> T.span (/= ' ') inputLine 131 | , rtsCurrentChannel rts) of 132 | (("cd", ""), _) -> replThreadLoop $ rts {rtsCurrentChannel = Nothing} 133 | (("cd", channel), _) -> 134 | replThreadLoop $ 135 | rts {rtsCurrentChannel = Just $ mkTwitchIrcChannel channel} 136 | (("say", message), Just channel) -> do 137 | atomically $ writeQueue (rtsCommandQueue rts) $ Say channel message 138 | replThreadLoop rts 139 | (("say", _), Nothing) -> do 140 | replPutStrLn 141 | replHandle 142 | "No current channel to say anything to is selected" 143 | replThreadLoop rts 144 | (("quit", _), _) -> return () 145 | (("q", _), _) -> return () 146 | (("join", channel), _) -> do 147 | atomically $ 148 | writeQueue (rtsCommandQueue rts) $ 149 | JoinChannel $ mkTwitchIrcChannel channel 150 | replThreadLoop $ 151 | rts {rtsCurrentChannel = Just $ mkTwitchIrcChannel channel} 152 | (("part", _), Just channel) -> do 153 | atomically $ writeQueue (rtsCommandQueue rts) $ PartChannel channel 154 | replThreadLoop $ rts {rtsCurrentChannel = Nothing} 155 | (("ls", _), _) -> do 156 | withTransactionLogErrors 157 | (traverse_ (replPutStrLn replHandle . twitchIrcChannelText) <=< 158 | joinedChannels) 159 | replThreadLoop rts 160 | -- TODO(#212): addcmd in REPL should accept the argsRegex 161 | (("addcmd", cmdDef), _) -> do 162 | case T.dropWhile (== ' ') <$> T.span (/= ' ') cmdDef of 163 | ("", _) -> replPutStrLn replHandle "No name for new command is provided" 164 | (name, args) -> 165 | withTransactionLogErrors $ \dbConn -> 166 | void $ addCommand dbConn name args 167 | replThreadLoop rts 168 | (("addalias", aliasDef), _) -> do 169 | case T.dropWhile (== ' ') <$> T.span (/= ' ') aliasDef of 170 | ("", _) -> replPutStrLn replHandle "No name for new alias is provided" 171 | (alias, name) -> 172 | withTransactionLogErrors $ \dbConn -> addCommandName dbConn alias name 173 | replThreadLoop rts 174 | (("updatebttv", _), _) -> do 175 | withTransactionLogErrors $ \dbConn -> do 176 | let reportFailure = 177 | \case 178 | Left message -> hPrintf replHandle "[ERROR] %s\n" message 179 | Right _ -> return () 180 | replPutStrLn replHandle "Updating Global BTTV emotes..." 181 | reportFailure =<< 182 | runExceptT (updateBttvEmotes dbConn (rtsManager rts) Nothing) 183 | channels <- joinedChannels dbConn 184 | for_ channels $ \channel -> do 185 | hPrintf replHandle "Updating BTTV emotes for %s channel...\n" $ 186 | twitchIrcChannelText channel 187 | reportFailure =<< 188 | runExceptT (updateBttvEmotes dbConn (rtsManager rts) (Just channel)) 189 | replThreadLoop rts 190 | (("updateffz", _), _) -> do 191 | withTransactionLogErrors $ \dbConn -> do 192 | let reportFailure = 193 | \case 194 | Left message -> hPrintf replHandle "[ERROR] %s\n" message 195 | Right _ -> return () 196 | hPrintf replHandle "Updating Global FFZ emotes...\n" 197 | reportFailure =<< 198 | runExceptT (updateFfzEmotes dbConn (rtsManager rts) Nothing) 199 | channels <- joinedChannels dbConn 200 | for_ channels $ \channel -> do 201 | hPrintf replHandle "Update FFZ emotes for %s channel...\n" $ 202 | twitchIrcChannelText channel 203 | reportFailure =<< 204 | runExceptT (updateFfzEmotes dbConn (rtsManager rts) (Just channel)) 205 | replThreadLoop rts 206 | (("addrole", name), _) -> do 207 | withTransactionLogErrors $ \dbConn -> do 208 | role <- getTwitchRoleByName dbConn name 209 | case role of 210 | Just _ -> 211 | replPutStrLn replHandle $ "Role " <> name <> " already exists" 212 | Nothing -> do 213 | void $ addTwitchRole dbConn name 214 | replPutStrLn replHandle $ "Added a new role: " <> name 215 | replThreadLoop rts 216 | (("lsroles", _), _) -> do 217 | withTransactionLogErrors $ \dbConn -> do 218 | roles <- listTwitchRoles dbConn 219 | mapM_ (replPutStrLn replHandle . twitchRoleName) roles 220 | replThreadLoop rts 221 | (("delcmd", name), _) -> do 222 | withTransactionLogErrors $ \dbConn -> deleteCommandByName dbConn name 223 | replThreadLoop rts 224 | (("delalias", name), _) -> do 225 | withTransactionLogErrors $ \dbConn -> deleteCommandName dbConn name 226 | replThreadLoop rts 227 | (("assrole", _), _) -> do 228 | replPutStrLn 229 | replHandle 230 | "This command is deprecated. Use eval %assrole(\"\", \"\")" 231 | replThreadLoop rts 232 | (("retrain", _), _) -> do 233 | atomically $ writeQueue (rtsMarkovQueue rts) Retrain 234 | replPutStrLn replHandle "Scheduled Markov retraining..." 235 | replThreadLoop rts 236 | (("retrain-stop", _), _) -> do 237 | atomically $ writeQueue (rtsMarkovQueue rts) StopRetrain 238 | replPutStrLn replHandle "Retraining process has been stopped..." 239 | replThreadLoop rts 240 | (("eval", code), channel) -> do 241 | case snd <$> runParser expr code of 242 | Right ast -> 243 | withTransactionLogErrors $ \dbConn -> do 244 | evalResult <- 245 | runExceptT $ 246 | evalStateT (runEvalT $ evalExpr ast) $ 247 | EvalContext 248 | { ecVars = M.empty 249 | , ecSqliteConnection = dbConn 250 | , ecExitMonitor = rtsExitMonitor rts 251 | , ecPlatformContext = 252 | Erc 253 | EvalReplContext 254 | { ercTwitchChannel = channel 255 | , ercConfigTwitch = rtsConfigTwitch rts 256 | , ercConnAddr = rtsConnAddr rts 257 | } 258 | , ecLogQueue = rtsLogQueue rts 259 | , ecManager = rtsManager rts 260 | , ecFridayGistUpdateRequired = rtsFridayGistUpdateRequired rts 261 | } 262 | case evalResult of 263 | Right response -> replPutStrLn replHandle response 264 | Left (EvalError userMsg) -> 265 | replPutStrLn replHandle $ "[ERROR] " <> userMsg 266 | Left err -> replPutStrLn replHandle $ "[ERROR] " <> T.pack (show err) 267 | replThreadLoop rts 268 | (("retrain-pogress", _), _) -> do 269 | withMVar (rtsRetrainProgress rts) $ \case 270 | Just progress -> 271 | withTransactionLogErrors $ \dbConn -> do 272 | n <- 273 | maybe (0 :: Int) Sqlite.fromOnly . listToMaybe <$> 274 | Sqlite.queryNamed dbConn [sql|SELECT count(*) FROM TwitchLog|] [] 275 | replPutStrLn replHandle $ 276 | T.pack $ printf "Current progress: %d/%d" progress n 277 | Nothing -> 278 | replPutStrLn replHandle "There is no Markov retraining in place." 279 | replThreadLoop rts 280 | (("setprefix", prefix), chan) -> do 281 | withTransactionLogErrors $ \dbConn -> 282 | case chan of 283 | Nothing -> 284 | replPutStrLn replHandle "setprefix only works in a joined channel." 285 | Just channel -> do 286 | setPrefixOfJoinedChannel dbConn channel prefix 287 | replPutStrLn replHandle $ 288 | "Updated call prefix for channel " <> twitchIrcChannelText channel 289 | replThreadLoop rts 290 | ((unknown, _), _) -> do 291 | replPutStrLn replHandle $ "Unknown command: " <> unknown 292 | replThreadLoop rts 293 | 294 | data BackdoorThreadParams = BackdoorThreadParams 295 | { btpSqliteConnection :: !(MVar Sqlite.Connection) 296 | , btpCommandQueue :: !(WriteQueue ReplCommand) 297 | , btpConfigTwitch :: !(Maybe ConfigTwitch) 298 | , btpManager :: !HTTP.Manager 299 | , btpLogQueue :: !(WriteQueue LogEntry) 300 | , btpExitMonitor :: !Monitor.T 301 | , btpPort :: !Int 302 | , btpMarkovQueue :: !(WriteQueue MarkovCommand) 303 | , btpRetrainProgress :: !(MVar (Maybe Int)) 304 | , btpFridayGistUpdateRequired :: !(MVar ()) 305 | } 306 | 307 | instance ProvidesLogging BackdoorThreadParams where 308 | logEntry btp = logEntry $ btpLogQueue btp 309 | 310 | -- TODO(#231): CSRF token generation is weak 311 | -- - We are not using cryptographic RNG 312 | -- - The size and method of the generation based literally on nothing (some sort CSRF token generation research is required) 313 | csrfToken :: IO T.Text 314 | csrfToken = BS.encodeBase64 . BS.pack <$> replicateM 32 (randomRIO (0, 255)) 315 | 316 | backdoorThread :: BackdoorThreadParams -> IO () 317 | backdoorThread btp = do 318 | addr:_ <- 319 | getAddrInfo (Just hints) (Just "127.0.0.1") (Just $ show $ btpPort btp) 320 | bracket (open addr) close loop 321 | where 322 | hints = defaultHints {addrFlags = [AI_PASSIVE], addrSocketType = Stream} 323 | open addr = do 324 | sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) 325 | setSocketOption sock ReuseAddr 1 326 | bind sock (addrAddress addr) 327 | setCloseOnExecIfNeeded $ fdSocket sock 328 | listen sock 10 329 | return sock 330 | loop sock = do 331 | (conn, addr) <- accept sock 332 | -- TODO(#62): backdoor repl connection is not always closed upon the quit command 333 | void $ forkFinally (talk conn addr) (const $ close conn) 334 | loop sock 335 | talk conn addr = do 336 | logEntry btp $ 337 | LogEntry "BACKDOOR" $ 338 | T.pack (show addr) <> " has connected to the Backdoor gachiBASS" 339 | connHandle <- socketToHandle conn ReadWriteMode 340 | csrf <- csrfToken 341 | hPrintf connHandle "CSRF => %s\ncsrf> " csrf 342 | inputLine <- T.decodeUtf8 <$> BS.hGetLine connHandle 343 | when (inputLine == csrf) $ 344 | replThread $ 345 | ReplThreadParams 346 | { rtpSqliteConnection = btpSqliteConnection btp 347 | , rtpCommandQueue = btpCommandQueue btp 348 | , rtpManager = btpManager btp 349 | , rtpHandle = connHandle 350 | , rtpLogQueue = btpLogQueue btp 351 | , rtpExitMonitor = btpExitMonitor btp 352 | , rtpConnAddr = addr 353 | , rtpConfigTwitch = btpConfigTwitch btp 354 | , rtpMarkovQueue = btpMarkovQueue btp 355 | , rtpRetrainProgress = btpRetrainProgress btp 356 | , rtpFridayGistUpdateRequired = btpFridayGistUpdateRequired btp 357 | } 358 | hClose connHandle 359 | close conn 360 | -- TODO(#82): there is no REPL mechanism to update command cooldown 361 | -------------------------------------------------------------------------------- /src/KGBotka/Roles.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE ViewPatterns #-} 4 | 5 | module KGBotka.Roles 6 | ( assTwitchRoleToUser 7 | , getTwitchUserRoles 8 | , getTwitchRoleByName 9 | , TwitchRole(..) 10 | , TwitchBadgeRole(..) 11 | , addTwitchRole 12 | , listTwitchRoles 13 | ) where 14 | 15 | import Data.Int 16 | import Data.Maybe 17 | import qualified Data.Text as T 18 | import Database.SQLite.Simple 19 | import Database.SQLite.Simple.QQ 20 | import KGBotka.TwitchAPI 21 | 22 | data TwitchBadgeRole 23 | = TwitchSub 24 | | TwitchVip 25 | | TwitchBroadcaster 26 | | TwitchMod 27 | | TwitchFounder 28 | deriving (Eq, Show) 29 | 30 | data TwitchRole = TwitchRole 31 | { twitchRoleId :: Int64 32 | , twitchRoleName :: T.Text 33 | } deriving (Show) 34 | 35 | instance FromRow TwitchRole where 36 | fromRow = TwitchRole <$> field <*> field 37 | 38 | assTwitchRoleToUser :: Connection -> Int64 -> TwitchUserId -> IO () 39 | assTwitchRoleToUser conn roleId' userId' = 40 | executeNamed 41 | conn 42 | "INSERT INTO TwitchUserRoles (userId, roleId) \ 43 | \VALUES (:userId, :roleId);" 44 | [":userId" := userId', ":roleId" := roleId'] 45 | 46 | getTwitchUserRoles :: Connection -> TwitchUserId -> IO [TwitchRole] 47 | getTwitchUserRoles conn userId = queryNamed conn queryText [":userId" := userId] 48 | where 49 | queryText = 50 | "SELECT ur.roleId, r.name \ 51 | \FROM TwitchUserRoles ur \ 52 | \INNER JOIN TwitchRoles r \ 53 | \ON ur.roleId = r.id \ 54 | \WHERE ur.userId = :userId;" 55 | 56 | getTwitchRoleByName :: Connection -> T.Text -> IO (Maybe TwitchRole) 57 | getTwitchRoleByName conn name = 58 | listToMaybe <$> 59 | queryNamed 60 | conn 61 | "SELECT * FROM TwitchRoles \ 62 | \WHERE name = :roleName;" 63 | [":roleName" := name] 64 | 65 | addTwitchRole :: Connection -> T.Text -> IO Int64 66 | addTwitchRole dbConn name = do 67 | executeNamed 68 | dbConn 69 | [sql|INSERT INTO TwitchRoles (name) VALUES (:name)|] 70 | [":name" := name] 71 | lastInsertRowId dbConn 72 | 73 | listTwitchRoles :: Connection -> IO [TwitchRole] 74 | listTwitchRoles dbConn = 75 | queryNamed dbConn [sql|SELECT id, name FROM TwitchRoles |] [] 76 | -------------------------------------------------------------------------------- /src/KGBotka/Settings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module KGBotka.Settings 5 | ( Settings(..) 6 | , fetchSettings 7 | ) where 8 | 9 | import Data.Maybe 10 | import qualified Data.Text as T 11 | import Database.SQLite.Simple 12 | import Database.SQLite.Simple.QQ 13 | import KGBotka.Command 14 | 15 | -- FIXME(#124): Difference between KGBotka.Settings and KGBotka.Config is not clear 16 | data Settings = Settings 17 | { settingsFridayGithubGistId :: Maybe T.Text 18 | , settingsCallPrefix :: CallPrefix 19 | } deriving (Show) 20 | 21 | deserializeSettings :: [(T.Text, T.Text)] -> Settings 22 | deserializeSettings settingsMap = 23 | Settings 24 | { settingsFridayGithubGistId = lookup "fridayGithubGistId" settingsMap 25 | , settingsCallPrefix = 26 | CallPrefix $ fromMaybe "$" $ lookup "callPrefix" settingsMap 27 | } 28 | 29 | fetchSettings :: Connection -> IO Settings 30 | fetchSettings dbConn = 31 | deserializeSettings <$> queryNamed dbConn [sql|SELECT * FROM Settings;|] [] 32 | -------------------------------------------------------------------------------- /src/KGBotka/Sqlite.hs: -------------------------------------------------------------------------------- 1 | module KGBotka.Sqlite where 2 | 3 | import Control.Concurrent 4 | import Database.SQLite.Simple 5 | 6 | -- TODO(#208): make withLockedTransaction to always handle Exceptions from Sqlite library 7 | -- Give the user some endpoints to log the errors 8 | withLockedTransaction :: MVar Connection -> (Connection -> IO a) -> IO a 9 | withLockedTransaction mvarDbConn action = 10 | withMVar mvarDbConn $ \dbConn -> withTransaction dbConn (action dbConn) 11 | -------------------------------------------------------------------------------- /src/KGBotka/TwitchAPI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module KGBotka.TwitchAPI 4 | ( TwitchUser(..) 5 | , TwitchRes(..) 6 | , TwitchUserId(..) 7 | , getUsersByLogins 8 | , TwitchIrcChannel(..) 9 | , twitchIrcChannelText 10 | , mkTwitchIrcChannel 11 | , getStreamByLogin 12 | , twitchIrcChannelName 13 | , TwitchStream(..) 14 | ) where 15 | 16 | import Data.Aeson 17 | import Data.Aeson.Types 18 | import qualified Data.ByteString.Lazy as B 19 | import Data.List 20 | import Data.Maybe 21 | import Data.String 22 | import qualified Data.Text as T 23 | import Data.Text.Encoding (encodeUtf8) 24 | import Data.Time 25 | import Database.SQLite.Simple 26 | import Database.SQLite.Simple.FromField 27 | import Database.SQLite.Simple.ToField 28 | import Irc.Identifier (Identifier, idText, mkId) 29 | import KGBotka.Config 30 | import Network.HTTP.Client 31 | import Network.HTTP.Types.Status (Status(statusCode)) 32 | 33 | newtype TwitchUserId = 34 | TwitchUserId T.Text 35 | deriving (Show, Eq, Ord) 36 | 37 | instance IsString TwitchUserId where 38 | fromString = TwitchUserId . fromString 39 | 40 | instance ToField TwitchUserId where 41 | toField (TwitchUserId userId) = toField userId 42 | 43 | instance FromField TwitchUserId where 44 | fromField f = TwitchUserId <$> fromField f 45 | 46 | instance FromRow TwitchUserId where 47 | fromRow = TwitchUserId <$> field 48 | 49 | instance FromJSON TwitchUserId where 50 | parseJSON v = TwitchUserId <$> parseJSON v 51 | 52 | newtype TwitchIrcChannel = 53 | TwitchIrcChannel Identifier 54 | deriving (Ord, Eq, Show) 55 | 56 | twitchIrcChannelText :: TwitchIrcChannel -> T.Text 57 | twitchIrcChannelText (TwitchIrcChannel ident) = idText ident 58 | 59 | mkTwitchIrcChannel :: T.Text -> TwitchIrcChannel 60 | mkTwitchIrcChannel = TwitchIrcChannel . mkId 61 | 62 | twitchIrcChannelName :: TwitchIrcChannel -> T.Text 63 | twitchIrcChannelName channel = 64 | case T.uncons channelText of 65 | Just ('#', channelName) -> channelName 66 | _ -> channelText 67 | where 68 | channelText = twitchIrcChannelText channel 69 | 70 | instance IsString TwitchIrcChannel where 71 | fromString = TwitchIrcChannel . fromString 72 | 73 | instance FromField TwitchIrcChannel where 74 | fromField f = TwitchIrcChannel . mkId <$> fromField f 75 | 76 | instance ToField TwitchIrcChannel where 77 | toField (TwitchIrcChannel ident) = toField $ idText ident 78 | 79 | data TwitchUser = TwitchUser 80 | { twitchUserId :: TwitchUserId 81 | , twitchUserLogin :: T.Text 82 | } deriving (Show) 83 | 84 | data TwitchErr = TwitchErr 85 | { twitchErrMessage :: T.Text 86 | , twitchErrStatus :: Int 87 | , twitchErrError :: T.Text 88 | } deriving (Show) 89 | 90 | instance FromJSON TwitchErr where 91 | parseJSON (Object v) = 92 | TwitchErr <$> v .: "message" <*> v .: "status" <*> v .: "error" 93 | parseJSON invalid = typeMismatch "TwitchErr" invalid 94 | 95 | newtype TwitchRes a = TwitchRes 96 | { twitchResData :: a 97 | } 98 | 99 | instance FromJSON a => FromJSON (TwitchRes a) where 100 | parseJSON (Object v) = TwitchRes <$> v .: "data" 101 | parseJSON invalid = typeMismatch "TwitchRes" invalid 102 | 103 | data TwitchStream = TwitchStream 104 | { tsStartedAt :: UTCTime 105 | , tsTitle :: T.Text 106 | } deriving (Eq, Show) 107 | 108 | instance FromJSON TwitchStream where 109 | parseJSON (Object obj) = 110 | TwitchStream <$> obj .: "started_at" <*> obj .: "title" 111 | parseJSON invalid = typeMismatch "TwitchStream" invalid 112 | 113 | instance FromJSON TwitchUser where 114 | parseJSON (Object v) = TwitchUser <$> v .: "id" <*> v .: "login" 115 | parseJSON invalid = typeMismatch "TwitchUser" invalid 116 | 117 | extractTwitchResponse :: 118 | FromJSON a => Response B.ByteString -> Either TwitchErr a 119 | extractTwitchResponse response 120 | | status >= 400 = 121 | case eitherDecode body of 122 | Right err -> Left err 123 | Left err -> Left $ TwitchErr (T.pack err) 413 "Parsing error" 124 | | otherwise = 125 | case eitherDecode body of 126 | Right res -> Right (twitchResData res) 127 | Left err -> Left $ TwitchErr (T.pack err) 413 "Parsing error" 128 | where 129 | body = responseBody response 130 | status = statusCode $ responseStatus response 131 | 132 | getUsersByLogins :: 133 | Manager -> ConfigTwitch -> [T.Text] -> IO (Either TwitchErr [TwitchUser]) 134 | getUsersByLogins manager ConfigTwitch { configTwitchClientId = clientId 135 | , configTwitchToken = token 136 | } users 137 | -- TODO(#222): Consider using network-uri for constructing uri-s 138 | -- 139 | -- Grep for @uri 140 | = do 141 | let url = 142 | "https://api.twitch.tv/helix/users?" <> 143 | T.concat (intersperse "&" $ map ("login=" <>) users) 144 | request <- parseRequest $ T.unpack url 145 | response <- 146 | httpLbs 147 | request 148 | { requestHeaders = 149 | ("Authorization", encodeUtf8 ("Bearer " <> token)) : 150 | ("Client-ID", encodeUtf8 clientId) : requestHeaders request 151 | } 152 | manager 153 | return $ extractTwitchResponse response 154 | 155 | getStreamByLogin :: 156 | Manager 157 | -> ConfigTwitch 158 | -> T.Text 159 | -> IO (Either TwitchErr (Maybe TwitchStream)) 160 | getStreamByLogin manager ConfigTwitch { configTwitchClientId = clientId 161 | , configTwitchToken = token 162 | } login 163 | -- @uri 164 | = do 165 | let url = "https://api.twitch.tv/helix/streams?user_login=" <> T.unpack login 166 | request <- parseRequest url 167 | response <- 168 | httpLbs 169 | request 170 | { requestHeaders = 171 | ("Authorization", encodeUtf8 ("Bearer " <> token)) : 172 | ("Client-ID", encodeUtf8 clientId) : requestHeaders request 173 | } 174 | manager 175 | return $ listToMaybe <$> extractTwitchResponse response 176 | -------------------------------------------------------------------------------- /src/KGBotka/TwitchLog.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module KGBotka.TwitchLog 4 | ( logMessage 5 | ) where 6 | 7 | import qualified Data.Text as T 8 | import Database.SQLite.Simple 9 | import KGBotka.Roles 10 | import KGBotka.TwitchAPI 11 | 12 | logMessage :: 13 | Connection 14 | -> TwitchIrcChannel 15 | -> TwitchUserId 16 | -> T.Text 17 | -> Maybe T.Text 18 | -> [TwitchRole] 19 | -> [TwitchBadgeRole] 20 | -> T.Text 21 | -> IO () 22 | logMessage conn channel senderTwitchId senderTwitchName senderTwitchDisplayName senderTwitchRoles senderTwitchBadgeRoles message = 23 | executeNamed 24 | conn 25 | "INSERT INTO TwitchLog ( \ 26 | \ channel, \ 27 | \ senderTwitchId, \ 28 | \ senderTwitchName, \ 29 | \ senderTwitchDisplayName, \ 30 | \ senderTwitchRoles, \ 31 | \ senderTwitchBadgeRoles, \ 32 | \ message \ 33 | \) VALUES ( \ 34 | \ :channel, \ 35 | \ :senderTwitchId, \ 36 | \ :senderTwitchName, \ 37 | \ :senderTwitchDisplayName, \ 38 | \ :senderTwitchRoles, \ 39 | \ :senderTwitchBadgeRoles, \ 40 | \ :message \ 41 | \)" 42 | [ ":channel" := channel 43 | , ":senderTwitchId" := senderTwitchId 44 | , ":senderTwitchName" := senderTwitchName 45 | , ":senderTwitchDisplayName" := senderTwitchDisplayName 46 | -- NOTE: Roles and BadgeRoles in this table are supposed to be 47 | -- informative. Basically they are just a reflection of what they 48 | -- were at the time. Should not be generally used for any 49 | -- authentication or decision making. 50 | , ":senderTwitchRoles" := show senderTwitchRoles 51 | , ":senderTwitchBadgeRoles" := show senderTwitchBadgeRoles 52 | , ":message" := message 53 | ] 54 | -------------------------------------------------------------------------------- /src/KGBotka/TwitchThread.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module KGBotka.TwitchThread 5 | ( twitchThread 6 | , TwitchThreadParams(..) 7 | ) where 8 | 9 | import Control.Concurrent 10 | import Control.Concurrent.STM 11 | import Control.Exception 12 | import Control.Monad 13 | import Control.Monad.Trans.Eval 14 | import Control.Monad.Trans.Except 15 | import Control.Monad.Trans.State.Strict 16 | import Data.Char 17 | import Data.Foldable 18 | import Data.List 19 | import qualified Data.Map as M 20 | import Data.Maybe 21 | import Data.Monoid 22 | import qualified Data.Text as T 23 | import qualified Database.SQLite.Simple as Sqlite 24 | import Hookup 25 | import Irc.Commands 26 | import Irc.Identifier (idText) 27 | import Irc.Message 28 | import Irc.RawIrcMsg 29 | import Irc.UserInfo (userNick) 30 | import KGBotka.Command 31 | import KGBotka.Config 32 | import KGBotka.Eval 33 | import KGBotka.JoinedTwitchChannels 34 | import KGBotka.Log 35 | import KGBotka.Markov 36 | import qualified KGBotka.Monitor as Monitor 37 | import KGBotka.Queue 38 | import KGBotka.Repl 39 | import KGBotka.Roles 40 | import KGBotka.Sqlite 41 | import KGBotka.TwitchAPI 42 | import KGBotka.TwitchLog 43 | import qualified Network.HTTP.Client as HTTP 44 | import Network.Socket (Family(AF_INET)) 45 | import Text.Printf 46 | 47 | roleOfBadge :: T.Text -> Maybe TwitchBadgeRole 48 | roleOfBadge badge 49 | | "subscriber" `T.isPrefixOf` badge = Just TwitchSub 50 | | "vip" `T.isPrefixOf` badge = Just TwitchVip 51 | | "broadcaster" `T.isPrefixOf` badge = Just TwitchBroadcaster 52 | | "moderator" `T.isPrefixOf` badge = Just TwitchMod 53 | | "founder" `T.isPrefixOf` badge = Just TwitchFounder 54 | | otherwise = Nothing 55 | 56 | badgeRolesFromRawIrcMsg :: RawIrcMsg -> [TwitchBadgeRole] 57 | badgeRolesFromRawIrcMsg RawIrcMsg {_msgTags = tags} = 58 | fromMaybe [] $ do 59 | badges <- lookupEntryValue "badges" tags 60 | return $ mapMaybe roleOfBadge $ T.splitOn "," badges 61 | 62 | tagEntryPair :: TagEntry -> (T.Text, T.Text) 63 | tagEntryPair (TagEntry name value) = (name, value) 64 | 65 | tagEntryName :: TagEntry -> T.Text 66 | tagEntryName = fst . tagEntryPair 67 | 68 | tagEntryValue :: TagEntry -> T.Text 69 | tagEntryValue = snd . tagEntryPair 70 | 71 | lookupEntryValue :: T.Text -> [TagEntry] -> Maybe T.Text 72 | lookupEntryValue name = fmap tagEntryValue . find ((== name) . tagEntryName) 73 | 74 | userIdFromRawIrcMsg :: RawIrcMsg -> Maybe TwitchUserId 75 | userIdFromRawIrcMsg RawIrcMsg {_msgTags = tags} = 76 | TwitchUserId <$> lookupEntryValue "user-id" tags 77 | 78 | data TwitchThreadParams = TwitchThreadParams 79 | { ttpLogQueue :: !(WriteQueue LogEntry) 80 | , ttpReplQueue :: !(ReadQueue ReplCommand) 81 | , ttpExitMonitor :: !Monitor.T 82 | , ttpSqliteConnection :: !(MVar Sqlite.Connection) 83 | , ttpManager :: !HTTP.Manager 84 | , ttpConfig :: !(Maybe ConfigTwitch) 85 | , ttpFridayGistUpdateRequired :: !(MVar ()) 86 | , ttpMarkovQueue :: !(WriteQueue MarkovCommand) 87 | } 88 | 89 | instance ProvidesLogging TwitchThreadParams where 90 | logEntry ttp = logEntry $ ttpLogQueue ttp 91 | 92 | data TwitchThreadState = TwitchThreadState 93 | { ttsLogQueue :: !(WriteQueue LogEntry) 94 | , ttsReplQueue :: !(ReadQueue ReplCommand) 95 | , ttsSqliteConnection :: !(MVar Sqlite.Connection) 96 | , ttsExitMonitor :: !Monitor.T 97 | , ttsManager :: !HTTP.Manager 98 | , ttsConfig :: ConfigTwitch 99 | , ttsIncomingQueue :: !(ReadQueue RawIrcMsg) 100 | , ttsOutgoingQueue :: !(WriteQueue OutMsg) 101 | , ttsFridayGistUpdateRequired :: !(MVar ()) 102 | , ttsMarkovQueue :: !(WriteQueue MarkovCommand) 103 | } 104 | 105 | instance ProvidesLogging TwitchThreadState where 106 | logEntry tts = logEntry $ ttsLogQueue tts 107 | 108 | withConnection :: ConnectionParams -> (Connection -> IO a) -> IO a 109 | withConnection params = bracket (connect params) close 110 | 111 | twitchConnectionParams :: ConnectionParams 112 | twitchConnectionParams = 113 | ConnectionParams 114 | { cpHost = "irc.chat.twitch.tv" 115 | , cpPort = 443 116 | , cpTls = 117 | Just 118 | TlsParams 119 | { tpClientCertificate = Nothing 120 | , tpClientPrivateKey = Nothing 121 | , tpServerCertificate = Nothing 122 | , tpCipherSuite = "HIGH" 123 | , tpInsecure = False 124 | } 125 | , cpSocks = Nothing 126 | , cpFamily = AF_INET 127 | } 128 | 129 | authorize :: ConfigTwitch -> Connection -> IO () 130 | authorize conf conn = do 131 | sendMsg conn (ircPass $ "oauth:" <> configTwitchToken conf) 132 | sendMsg conn (ircNick $ configTwitchAccount conf) 133 | sendMsg conn (ircCapReq ["twitch.tv/tags"]) 134 | 135 | sendMsg :: Connection -> RawIrcMsg -> IO () 136 | sendMsg conn msg = send conn (renderRawIrcMsg msg) 137 | 138 | maxIrcMessage :: Int 139 | maxIrcMessage = 500 * 4 140 | 141 | readIrcLine :: ProvidesLogging l => Connection -> l -> IO (Maybe RawIrcMsg) 142 | readIrcLine conn l = do 143 | mb <- 144 | catch 145 | (recvLine conn maxIrcMessage) 146 | (\case 147 | LineTooLong -> do 148 | logEntry l $ 149 | LogEntry "TWITCH" "[WARN] Received LineTooLong. Ignoring it..." 150 | return Nothing 151 | e -> throwIO e) 152 | case (parseRawIrcMsg . asUtf8) =<< mb of 153 | Just msg -> return (Just msg) 154 | Nothing -> return Nothing 155 | 156 | twitchIncomingThread :: 157 | ProvidesLogging l => Connection -> WriteQueue RawIrcMsg -> l -> IO () 158 | twitchIncomingThread conn queue l = do 159 | mb <- readIrcLine conn l 160 | for_ mb $ atomically . writeQueue queue 161 | twitchIncomingThread conn queue l 162 | 163 | data OutMsg 164 | = OutPrivMsg TwitchIrcChannel 165 | T.Text 166 | | OutJoinMsg TwitchIrcChannel 167 | | OutPartMsg TwitchIrcChannel 168 | | OutPongMsg [T.Text] 169 | 170 | renderOutMsg :: OutMsg -> RawIrcMsg 171 | renderOutMsg (OutPrivMsg (TwitchIrcChannel channel) message) = 172 | ircPrivmsg (idText channel) message 173 | renderOutMsg (OutJoinMsg channel) = 174 | ircJoin (twitchIrcChannelText channel) Nothing 175 | renderOutMsg (OutPartMsg (TwitchIrcChannel channelId)) = ircPart channelId "" 176 | renderOutMsg (OutPongMsg xs) = ircPong xs 177 | 178 | twitchLimitFilter :: OutMsg -> OutMsg 179 | twitchLimitFilter (OutPrivMsg channel message) = 180 | OutPrivMsg channel (T.take 500 message) 181 | twitchLimitFilter x = x 182 | 183 | twitchOutgoingThread :: Connection -> ReadQueue OutMsg -> IO () 184 | twitchOutgoingThread conn queue = do 185 | msg <- atomically $ readQueue queue 186 | sendMsg conn $ renderOutMsg $ twitchLimitFilter msg 187 | twitchOutgoingThread conn queue 188 | 189 | twitchThread :: TwitchThreadParams -> IO () 190 | twitchThread ttp = 191 | case ttpConfig ttp of 192 | Just config -> 193 | withConnection twitchConnectionParams $ \twitchConn -> do 194 | authorize config twitchConn 195 | incomingIrcQueue <- atomically newTQueue 196 | void $ 197 | forkIO $ 198 | twitchIncomingThread twitchConn (WriteQueue incomingIrcQueue) ttp 199 | outgoingIrcQueue <- atomically newTQueue 200 | channelsToJoin <- 201 | withLockedTransaction (ttpSqliteConnection ttp) joinedChannels 202 | atomically $ 203 | for_ channelsToJoin $ \channel -> 204 | writeQueue (WriteQueue outgoingIrcQueue) $ OutJoinMsg channel 205 | void $ 206 | forkIO $ twitchOutgoingThread twitchConn $ ReadQueue outgoingIrcQueue 207 | twitchThreadLoop 208 | TwitchThreadState 209 | { ttsLogQueue = ttpLogQueue ttp 210 | , ttsReplQueue = ttpReplQueue ttp 211 | , ttsSqliteConnection = ttpSqliteConnection ttp 212 | , ttsExitMonitor = ttpExitMonitor ttp 213 | , ttsManager = ttpManager ttp 214 | , ttsConfig = config 215 | , ttsIncomingQueue = ReadQueue incomingIrcQueue 216 | , ttsOutgoingQueue = WriteQueue outgoingIrcQueue 217 | , ttsFridayGistUpdateRequired = ttpFridayGistUpdateRequired ttp 218 | , ttsMarkovQueue = ttpMarkovQueue ttp 219 | } 220 | Nothing -> 221 | atomically $ 222 | writeQueue (ttpLogQueue ttp) $ 223 | LogEntry "TWITCH" "[ERROR] Twitch configuration not found" 224 | 225 | countForbidden :: T.Text -> Int 226 | countForbidden = T.length . T.filter (not . isAllowed) 227 | 228 | isAllowed :: Char -> Bool 229 | isAllowed = getAny . foldMap (Any .) [isAlpha, isNumber, isSpace, isPunctuation] 230 | 231 | processControlMsgs :: TwitchThreadState -> [RawIrcMsg] -> IO () 232 | processControlMsgs tts messages = do 233 | let outgoingQueue = ttsOutgoingQueue tts 234 | for_ messages $ \msg -> do 235 | let cookedMsg = cookIrcMsg msg 236 | logEntry tts $ LogEntry "TWITCH" $ T.pack $ show msg 237 | case cookedMsg of 238 | Ping xs -> atomically $ writeQueue outgoingQueue $ OutPongMsg xs 239 | Join _ channelId _ -> 240 | withLockedTransaction (ttsSqliteConnection tts) $ \dbConn -> 241 | registerJoinedChannel dbConn $ TwitchIrcChannel channelId 242 | Part _ channelId _ -> 243 | withLockedTransaction (ttsSqliteConnection tts) $ \dbConn -> 244 | unregisterJoinedChannel dbConn $ TwitchIrcChannel channelId 245 | _ -> return () 246 | 247 | processUserMsgs :: 248 | Sqlite.Connection -> TwitchThreadState -> [RawIrcMsg] -> IO () 249 | processUserMsgs dbConn tts messages = do 250 | let outgoingQueue = ttsOutgoingQueue tts 251 | let manager = ttsManager tts 252 | let botLogin = configTwitchAccount $ ttsConfig tts 253 | for_ messages $ \msg -> do 254 | let cookedMsg = cookIrcMsg msg 255 | logEntry tts $ LogEntry "TWITCH" $ T.pack $ show msg 256 | case cookedMsg of 257 | Privmsg userInfo channelId message -> 258 | case userIdFromRawIrcMsg msg of 259 | Just senderId -> do 260 | roles <- getTwitchUserRoles dbConn senderId 261 | let badgeRoles = badgeRolesFromRawIrcMsg msg 262 | let displayName = lookupEntryValue "display-name" $ _msgTags msg 263 | let senderName = idText $ userNick userInfo 264 | let channel = TwitchIrcChannel channelId 265 | if T.toLower senderName /= T.toLower botLogin 266 | then do 267 | logMessage 268 | dbConn 269 | channel 270 | senderId 271 | senderName 272 | displayName 273 | roles 274 | badgeRoles 275 | message 276 | atomically $ 277 | writeQueue (ttsMarkovQueue tts) $ NewSentence message 278 | let forbiddenCharLimit = 100 279 | if countForbidden message < forbiddenCharLimit 280 | then do 281 | prefix <- callPrefixOfJoinedChannel dbConn channel 282 | case parseCommandPipe 283 | (CallPrefix prefix) 284 | (PipeSuffix "|") 285 | message of 286 | [] -> 287 | when 288 | (T.toUpper (configTwitchAccount $ ttsConfig tts) `T.isInfixOf` 289 | T.toUpper message) $ do 290 | markovResponse <- genMarkovSentence dbConn Nothing 291 | atomically $ 292 | writeQueue outgoingQueue $ 293 | OutPrivMsg channel $ 294 | twitchCmdEscape $ 295 | T.pack $ printf "@%s %s" senderName markovResponse 296 | pipe -> do 297 | evalResult <- 298 | runExceptT $ 299 | evalStateT (runEvalT $ evalCommandPipe pipe) $ 300 | EvalContext 301 | { ecVars = M.empty 302 | , ecSqliteConnection = dbConn 303 | , ecExitMonitor = ttsExitMonitor tts 304 | , ecPlatformContext = 305 | Etc 306 | EvalTwitchContext 307 | { etcSenderId = senderId 308 | , etcSenderName = senderName 309 | , etcChannel = channel 310 | , etcBadgeRoles = badgeRoles 311 | , etcRoles = roles 312 | , etcConfigTwitch = ttsConfig tts 313 | , etcTwitchEmotes = 314 | do emotesTag <- 315 | lookupEntryValue "emotes" $ 316 | _msgTags msg 317 | if not $ T.null emotesTag 318 | then do 319 | emoteDesc <- 320 | listToMaybe $ 321 | T.splitOn "/" emotesTag 322 | listToMaybe $ 323 | T.splitOn ":" emoteDesc 324 | else Nothing 325 | } 326 | , ecLogQueue = ttsLogQueue tts 327 | , ecManager = manager 328 | , ecFridayGistUpdateRequired = 329 | ttsFridayGistUpdateRequired tts 330 | } 331 | atomically $ 332 | case evalResult of 333 | Right commandResponse -> 334 | writeQueue outgoingQueue $ 335 | OutPrivMsg channel $ 336 | twitchCmdEscape commandResponse 337 | Left (EvalError userMsg) -> 338 | writeQueue outgoingQueue $ 339 | OutPrivMsg channel $ twitchCmdEscape userMsg 340 | else atomically $ do 341 | writeQueue outgoingQueue $ 342 | OutPrivMsg channel $ 343 | T.pack $ 344 | printf "/timeout %s %d" senderName (30 :: Int) 345 | writeQueue outgoingQueue $ 346 | OutPrivMsg channel $ 347 | T.pack $ 348 | printf 349 | "@%s ASCII spam is not allowed. Use !asciify command." 350 | senderName 351 | else logEntry tts $ 352 | LogEntry "TWITCH" "WARNING: Bot received its own message" 353 | Nothing -> 354 | logEntry tts $ 355 | LogEntry "TWITCH" $ 356 | "ERROR: Could not extract twitch user id from PRIVMSG " <> 357 | T.pack (show msg) 358 | _ -> return () 359 | 360 | twitchThreadLoop :: TwitchThreadState -> IO () 361 | twitchThreadLoop tts = do 362 | threadDelay 10000 -- to prevent busy looping 363 | let incomingQueue = ttsIncomingQueue tts 364 | messages <- atomically $ flushQueue incomingQueue 365 | let (userMessages, controlMessages) = 366 | partition (\x -> _msgCommand x == "PRIVMSG") messages 367 | processControlMsgs tts controlMessages 368 | catch 369 | (withMVar (ttsSqliteConnection tts) $ \dbConn -> 370 | Sqlite.withTransaction dbConn $ processUserMsgs dbConn tts userMessages) 371 | (\e -> 372 | atomically $ 373 | writeQueue (ttsLogQueue tts) $ 374 | LogEntry "SQLITE" $ T.pack $ show (e :: SomeException)) 375 | atomically $ do 376 | let outgoingQueue = ttsOutgoingQueue tts 377 | let replQueue = ttsReplQueue tts 378 | replCommand <- tryReadQueue replQueue 379 | case replCommand of 380 | Just (Say channel msg) -> 381 | writeQueue outgoingQueue $ OutPrivMsg channel msg 382 | Just (JoinChannel channel) -> 383 | writeQueue outgoingQueue $ OutJoinMsg channel 384 | Just (PartChannel channel) -> 385 | writeQueue outgoingQueue $ OutPartMsg channel 386 | Nothing -> return () 387 | twitchThreadLoop tts 388 | 389 | twitchCmdEscape :: T.Text -> T.Text 390 | twitchCmdEscape = T.dropWhile (`elem` ['/', '.']) . T.strip 391 | -------------------------------------------------------------------------------- /src/KGBotka/Xkcd.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module KGBotka.Xkcd where 5 | 6 | import Data.Aeson 7 | import Data.Aeson.Types 8 | import Data.Char 9 | import Data.Foldable 10 | import Data.Int 11 | import Data.List 12 | import Data.Maybe 13 | import qualified Data.Text as T 14 | import qualified Database.SQLite.Simple as Sqlite 15 | import Database.SQLite.Simple (NamedParam(..)) 16 | import Database.SQLite.Simple.QQ 17 | import qualified Network.HTTP.Client as HTTP 18 | import Text.Printf 19 | 20 | type XkcdNum = Int64 21 | 22 | data Xkcd = Xkcd 23 | { xkcdNum :: XkcdNum 24 | , xkcdTitle :: T.Text 25 | , xkcdImg :: T.Text 26 | , xkcdAlt :: T.Text 27 | , xkcdTranscript :: T.Text 28 | } deriving (Eq, Show) 29 | 30 | instance FromJSON Xkcd where 31 | parseJSON (Object v) = 32 | Xkcd <$> v .: "num" <*> v .: "title" <*> v .: "img" <*> v .: "alt" <*> 33 | v .: "transcript" 34 | parseJSON invalid = typeMismatch "Xkcd" invalid 35 | 36 | queryXkcdByURL :: HTTP.Manager -> String -> IO Xkcd 37 | queryXkcdByURL manager url = do 38 | request <- HTTP.parseRequest url 39 | response <- HTTP.httpLbs request manager 40 | case eitherDecode $ HTTP.responseBody response of 41 | Right xkcd -> return xkcd 42 | Left errorMessage -> error errorMessage 43 | 44 | queryCurrentXkcd :: HTTP.Manager -> IO Xkcd 45 | queryCurrentXkcd manager = queryXkcdByURL manager "https://xkcd.com/info.0.json" 46 | 47 | queryXkcdById :: HTTP.Manager -> XkcdNum -> IO Xkcd 48 | queryXkcdById manager num = 49 | queryXkcdByURL manager $ printf "https://xkcd.com/%d/info.0.json" num 50 | 51 | dumpXkcdToDb :: Xkcd -> Sqlite.Connection -> IO () 52 | dumpXkcdToDb Xkcd { xkcdNum = num 53 | , xkcdTitle = title 54 | , xkcdImg = img 55 | , xkcdAlt = alt 56 | , xkcdTranscript = transcript 57 | } dbConn = 58 | Sqlite.executeNamed 59 | dbConn 60 | [sql|INSERT INTO xkcd (num, title, img, alt, transcript) 61 | VALUES (:num, :title, :img, :alt, :transcript)|] 62 | [ ":num" := num 63 | , ":title" := title 64 | , ":img" := img 65 | , ":alt" := alt 66 | , ":transcript" := transcript 67 | ] 68 | 69 | instance Sqlite.FromRow Xkcd where 70 | fromRow = 71 | Xkcd <$> Sqlite.field <*> Sqlite.field <*> Sqlite.field <*> Sqlite.field <*> 72 | Sqlite.field 73 | 74 | chunks :: Int -> [a] -> [[a]] 75 | chunks _ [] = [] 76 | chunks n xs = take n xs : chunks n (drop n xs) 77 | 78 | getLastDumpedXkcd :: Sqlite.Connection -> IO (Maybe Xkcd) 79 | getLastDumpedXkcd dbConn = 80 | listToMaybe <$> 81 | Sqlite.queryNamed 82 | dbConn 83 | [sql|select num, title, img, alt, transcript 84 | from xkcd order by num desc limit 1|] 85 | [] 86 | 87 | textAsTerms :: T.Text -> [T.Text] 88 | textAsTerms = 89 | map (T.map toUpper) . 90 | filter (T.all isAlphaNum) . T.groupBy (\x y -> isAlphaNum x == isAlphaNum y) 91 | 92 | indexXkcd :: Sqlite.Connection -> Xkcd -> IO () 93 | indexXkcd dbConn xkcd = do 94 | let terms = 95 | textAsTerms (xkcdTranscript xkcd) <> textAsTerms (xkcdTitle xkcd) <> 96 | textAsTerms (xkcdAlt xkcd) 97 | traverse_ 98 | (\g -> 99 | let term = head g 100 | freq = length g 101 | in Sqlite.executeNamed 102 | dbConn 103 | [sql|INSERT INTO xkcd_tf_idf (term, freq, num) 104 | VALUES (:term, :freq, :num);|] 105 | [":term" := term, ":freq" := freq, ":num" := xkcdNum xkcd]) $ 106 | group $ sort terms 107 | 108 | -- TODO(#238): there is no way to update xkcd_tf_idf from within the bot 109 | searchXkcdInDbByTerm :: Sqlite.Connection -> [T.Text] -> IO (Maybe Xkcd) 110 | searchXkcdInDbByTerm _ [] = return Nothing 111 | searchXkcdInDbByTerm dbConn terms = 112 | listToMaybe <$> 113 | Sqlite.queryNamed 114 | dbConn 115 | ([sql|SELECT xkcd.num, 116 | xkcd.title, 117 | xkcd.img, 118 | xkcd.alt, 119 | xkcd.transcript 120 | FROM xkcd_tf_idf 121 | INNER JOIN xkcd ON xkcd_tf_idf.num = xkcd.num 122 | WHERE |] <> 123 | generateTermsQuery (length terms) <> 124 | [sql| GROUP BY xkcd.num 125 | HAVING count(xkcd_tf_idf.term) = :termCount 126 | ORDER BY sum(xkcd_tf_idf.freq) DESC;|]) 127 | ([":termCount" := length terms] <> generateTermsBindings terms) 128 | 129 | generateTermsQuery :: Int -> Sqlite.Query 130 | generateTermsQuery n = 131 | Sqlite.Query $ 132 | T.unwords $ 133 | intersperse "or" $ 134 | map (T.pack . printf "xkcd_tf_idf.term = upper(:term%d)") [1 .. n] 135 | 136 | generateTermsBindings :: [T.Text] -> [NamedParam] 137 | generateTermsBindings terms = 138 | zipWith 139 | (\i term -> T.pack (printf ":term%d" i) := term) 140 | [1 .. length terms] 141 | terms 142 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | 4 | module Main 5 | ( main 6 | , ConfigTwitch(..) 7 | ) where 8 | 9 | import Control.Concurrent 10 | import Control.Concurrent.STM 11 | import Control.Exception 12 | import Data.Aeson 13 | import Data.Foldable 14 | import Data.Functor 15 | import qualified Database.SQLite.Simple as Sqlite 16 | import KGBotka.Config 17 | import KGBotka.DiscordThread 18 | import KGBotka.GithubThread 19 | import KGBotka.Log 20 | import KGBotka.Markov 21 | import KGBotka.Migration 22 | import qualified KGBotka.Monitor as Monitor 23 | import KGBotka.Queue 24 | import KGBotka.Repl 25 | import KGBotka.TwitchThread 26 | import qualified Network.HTTP.Client.TLS as TLS 27 | import System.Environment 28 | import System.Exit 29 | import System.IO 30 | 31 | -- TODO(#143): Periodic evaluation 32 | withForkIOs :: [IO ()] -> ([ThreadId] -> IO b) -> IO b 33 | withForkIOs ios = bracket (traverse forkIO ios) (traverse_ killThread) 34 | 35 | mainWithArgs :: [String] -> IO () 36 | mainWithArgs (configPath:databasePath:_) = do 37 | putStrLn $ "Your configuration file is " <> configPath 38 | eitherDecodeFileStrict configPath >>= \case 39 | Right config -> do 40 | exitMonitor <- Monitor.new 41 | replQueue <- atomically newTQueue 42 | rawLogQueue <- atomically newTQueue 43 | markovCmdQueue <- atomically newTQueue 44 | manager <- TLS.newTlsManager 45 | sqliteConnection <- newEmptyMVar 46 | fridayGistUpdateRequired <- newMVar () 47 | retrainProgress <- newMVar Nothing 48 | -- TODO(#67): there is no supavisah that restarts essential threads on crashing 49 | Sqlite.withConnection databasePath $ \dbConn -> do 50 | Sqlite.withTransaction dbConn $ migrateDatabase dbConn kgbotkaMigrations 51 | putMVar sqliteConnection dbConn 52 | withForkIOs 53 | [ twitchThread $ 54 | TwitchThreadParams 55 | { ttpReplQueue = ReadQueue replQueue 56 | , ttpSqliteConnection = sqliteConnection 57 | , ttpExitMonitor = exitMonitor 58 | , ttpLogQueue = WriteQueue rawLogQueue 59 | , ttpManager = manager 60 | , ttpConfig = configTwitch config 61 | , ttpFridayGistUpdateRequired = fridayGistUpdateRequired 62 | , ttpMarkovQueue = WriteQueue markovCmdQueue 63 | } 64 | , discordThread $ 65 | DiscordThreadParams 66 | { dtpConfig = configDiscord config 67 | , dtpLogQueue = WriteQueue rawLogQueue 68 | , dtpSqliteConnection = sqliteConnection 69 | , dtpExitMonitor = exitMonitor 70 | , dtpManager = manager 71 | , dtpFridayGistUpdateRequired = fridayGistUpdateRequired 72 | , dtpMarkovQueue = WriteQueue markovCmdQueue 73 | } 74 | , loggingThread "kgbotka.log" $ ReadQueue rawLogQueue 75 | , githubThread $ 76 | GithubThreadParams 77 | { gtpSqliteConnection = sqliteConnection 78 | , gtpManager = manager 79 | , gtpLogQueue = WriteQueue rawLogQueue 80 | , gtpConfig = configGithub config 81 | , gtpUpdateRequired = fridayGistUpdateRequired 82 | } 83 | , markovThread $ 84 | MarkovThreadParams 85 | { mtpSqliteConnection = sqliteConnection 86 | , mtpLogQueue = WriteQueue rawLogQueue 87 | , mtpCmdQueue = ReadQueue markovCmdQueue 88 | , mtpPageSize = 1000 89 | , mtpRetrainProgress = retrainProgress 90 | } 91 | , backdoorThread $ 92 | BackdoorThreadParams 93 | { btpSqliteConnection = sqliteConnection 94 | , btpCommandQueue = WriteQueue replQueue 95 | , btpConfigTwitch = configTwitch config 96 | , btpManager = manager 97 | , btpLogQueue = WriteQueue rawLogQueue 98 | , btpPort = 6969 -- TODO(#63): backdoor port is hardcoded 99 | , btpMarkovQueue = WriteQueue markovCmdQueue 100 | , btpRetrainProgress = retrainProgress 101 | , btpFridayGistUpdateRequired = fridayGistUpdateRequired 102 | , btpExitMonitor = exitMonitor 103 | } 104 | ] $ \_ -> do 105 | Monitor.wait exitMonitor 106 | void $ takeMVar sqliteConnection 107 | putStrLn "Done" 108 | Left errorMessage -> error errorMessage 109 | mainWithArgs _ = do 110 | hPutStrLn stderr "[ERROR] Not enough arguments provided" 111 | hPutStrLn stderr "Usage: ./kgbotka " 112 | exitFailure 113 | 114 | main :: IO () 115 | main = getArgs >>= mainWithArgs 116 | -------------------------------------------------------------------------------- /src/MigrationTool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | 5 | module Main where 6 | 7 | import Data.Aeson 8 | import Data.Foldable 9 | import Data.Functor 10 | import Database.SQLite.Simple 11 | import Database.SQLite.Simple.QQ 12 | import KGBotka.Command 13 | import KGBotka.Config 14 | import KGBotka.Migration 15 | import KGBotka.Roles 16 | import KGBotka.TwitchAPI 17 | import qualified Network.HTTP.Client as HTTP 18 | import qualified Network.HTTP.Client.TLS as TLS 19 | import System.Directory 20 | import System.Environment 21 | import System.IO 22 | import Text.Printf 23 | 24 | -- TODO(#146): MigrationTool does not convert quote database 25 | -- TODO(#147): populateHyperNerdBuiltinCommands does not support !trust and !untrust commands 26 | -- TODO(#148): populateHyperNerdBuiltinCommands does not support !updatebttv !updateffz 27 | populateHyperNerdBuiltinCommands :: Connection -> IO () 28 | populateHyperNerdBuiltinCommands dbConn = do 29 | void $ addCommand dbConn "addalias" "%addalias(%1)" 30 | void $ addCommand dbConn "addcmd" "%addcmd(%1)" 31 | void $ addCommand dbConn "asciify" "%asciify(%1)" 32 | void $ addCommand dbConn "calc" "%calc(%1)" 33 | void $ addCommand dbConn "cycle" "%cycle(%1)" 34 | void $ addCommand dbConn "derussify" "%derussify(%1)" 35 | void $ addCommand dbConn "friday" "%friday(%1)" 36 | void $ addCommand dbConn "help" "%help(%1)" 37 | void $ addCommand dbConn "markov" "%markov(%1)" 38 | void $ addCommand dbConn "nextstream" "%nextstream(%1)" 39 | void $ addCommand dbConn "nextvideo" "%nextvideo(%1)" 40 | void $ addCommand dbConn "omega" "%omega(%1)" 41 | void $ addCommand dbConn "russify" "%russify(%1)" 42 | void $ addCommand dbConn "showcmd" "%showcmd(%1)" 43 | void $ addCommand dbConn "updcmd" "%updcmd(%1)" 44 | void $ addCommand dbConn "vanish" "%vanish(%1)" 45 | void $ addCommand dbConn "version" "%version(%1)" 46 | void $ addCommand dbConn "video" "%video(%1)" 47 | void $ addCommand dbConn "videocount" "%videocount(%1)" 48 | void $ addCommand dbConn "videoq" "%videoq(%1)" 49 | 50 | -- TODO(#149): MigrationTool should rather called ConvertionTool or something like that. 51 | -- TODO(#150): Perform database conversion on CI for testing purposes 52 | convertCommands :: Connection -> IO () 53 | convertCommands dbConn = do 54 | legacyCommands <- 55 | queryNamed 56 | dbConn 57 | [sql|select name.propertyText, 58 | message.propertyText, 59 | times.propertyInt 60 | from (select entityId, entityName from EntityProperty 61 | where entityName = 'CustomCommand' 62 | group by entityId) commands 63 | left join EntityProperty name 64 | on (commands.entityId = name.entityId and 65 | commands.entityName = name.entityName and 66 | name.propertyName = 'name') 67 | left join EntityProperty message 68 | on (commands.entityId = message.entityId and 69 | commands.entityName = message.entityName and 70 | message.propertyName = 'message') 71 | left join EntityProperty times 72 | on (commands.entityId = times.entityId and 73 | commands.entityName = times.entityName and 74 | times.propertyName = 'times');|] 75 | [] 76 | traverse_ 77 | (\(name, code, times) -> do 78 | commandIdent <- addCommand dbConn name code 79 | executeNamed 80 | dbConn 81 | [sql|update Command 82 | set times = :times 83 | where id = :commandId|] 84 | [":times" := (times :: Int), ":commandId" := commandIdent]) 85 | legacyCommands 86 | 87 | chunks :: Int -> [a] -> [[a]] 88 | chunks _ [] = [] 89 | chunks n xs = take n xs : chunks n (drop n xs) 90 | 91 | -- TODO(#218): document that convertTrustedUsers requires querying Twitch API 92 | -- TODO(#225): document convertTrustedUsers limitations 93 | -- Renamed users are ignored 94 | convertTrustedUsers :: Connection -> HTTP.Manager -> ConfigTwitch -> IO () 95 | convertTrustedUsers dbConn manager config = do 96 | roleId <- addTwitchRole dbConn "trusted" 97 | logins <- 98 | map fromOnly <$> 99 | queryNamed 100 | dbConn 101 | [sql|select propertyText from EntityProperty 102 | where entityName = 'TrustedUser';|] 103 | [] 104 | for_ (chunks 100 logins) $ \loginsChunk -> do 105 | response <- getUsersByLogins manager config loginsChunk 106 | case response of 107 | Right users -> 108 | traverse_ (assTwitchRoleToUser dbConn roleId . twitchUserId) users 109 | Left err -> do 110 | hPutStrLn stderr "[ERROR] Querying user ids failed" 111 | error $ show err 112 | 113 | convertAliases :: Connection -> IO () 114 | convertAliases dbConn = do 115 | legacyAliases <- 116 | queryNamed 117 | dbConn 118 | [sql|select name.propertyText, redirect.propertyText 119 | from (select entityId, entityName from EntityProperty 120 | where entityName = 'Alias' 121 | group by entityId) alias 122 | left join EntityProperty name 123 | on (alias.entityId = name.entityId and 124 | alias.entityName = name.entityName and 125 | name.propertyName = 'name') 126 | left join EntityProperty redirect 127 | on (alias.entityId = redirect.entityId and 128 | alias.entityName = redirect.entityName and 129 | redirect.propertyName = 'redirect');|] 130 | [] 131 | -- TODO(#152): convertAliases silently ignores non existing command 132 | -- It should print a warning or something 133 | traverse_ (uncurry $ addCommandName dbConn) legacyAliases 134 | 135 | -- TODO(#195): document limitations of convertTwitchLogs 136 | -- Roles are not converted (not available) 137 | -- Messages without timestamps are ignored 138 | convertTwitchLogs :: Connection -> IO () 139 | convertTwitchLogs dbConn = 140 | executeNamed 141 | dbConn 142 | [sql|insert into TwitchLog (channel, 143 | senderTwitchName, 144 | senderTwitchRoles , 145 | senderTwitchBadgeRoles, 146 | message, 147 | messageTime) 148 | select substr(channel.propertyText, 149 | 16, 150 | length(channel.propertyText) - 16), 151 | user.propertyText, 152 | '[]', 153 | '[]', 154 | msg.propertyText, 155 | timestamp.propertyUTCTime 156 | from (select * from EntityProperty 157 | where entityName = 'LogRecord' 158 | group by entityId) record 159 | left join EntityProperty user 160 | on (record.entityId = user.entityId and 161 | record.entityName = user.entityName and 162 | user.propertyName = 'user') 163 | left join EntityProperty timestamp 164 | on (record.entityId = timestamp.entityId and 165 | record.entityName = timestamp.entityName and 166 | timestamp.propertyName = 'timestamp') 167 | left join EntityProperty msg 168 | on (record.entityId = msg.entityId and 169 | record.entityName = msg.entityName and 170 | msg.propertyName = 'msg') 171 | left join EntityProperty channel 172 | on (record.entityId = channel.entityId and 173 | record.entityName = channel.entityName and 174 | channel.propertyName = 'channel') 175 | where channel.propertyText like 'TwitchChannel "%"' 176 | -- NOTE: At some very brief moment of time HyperNerd 177 | -- was not saving timestamps. That was very long time 178 | -- ago and very brief, so if such messages occur, we can 179 | -- simply neglect them 180 | and timestamp.propertyUTCTime is not NULL;|] 181 | [] 182 | 183 | -- TODO(#196): document limitations of convertDiscordLogs 184 | -- - guildId is not converted (not available) 185 | -- - senderDiscordId is not converted (not available) 186 | convertDiscordLogs :: Connection -> IO () 187 | convertDiscordLogs dbConn = 188 | executeNamed 189 | dbConn 190 | [sql|insert into DiscordLog (guildId, 191 | channelId, 192 | senderDiscordId, 193 | senderDiscordDisplayName, 194 | message, 195 | messageTime) 196 | select NULL, 197 | substr(channel.propertyText, 16), 198 | NULL, 199 | user.propertyText, 200 | msg.propertyText, 201 | timestamp.propertyUTCTime 202 | from (select * from EntityProperty 203 | where entityName = 'LogRecord' 204 | group by entityId) record 205 | left join EntityProperty user 206 | on (record.entityId = user.entityId and 207 | record.entityName = user.entityName and 208 | user.propertyName = 'user') 209 | left join EntityProperty timestamp 210 | on (record.entityId = timestamp.entityId and 211 | record.entityName = timestamp.entityName and 212 | timestamp.propertyName = 'timestamp') 213 | left join EntityProperty msg 214 | on (record.entityId = msg.entityId and 215 | record.entityName = msg.entityName and 216 | msg.propertyName = 'msg') 217 | left join EntityProperty channel 218 | on (record.entityId = channel.entityId and 219 | record.entityName = channel.entityName and 220 | channel.propertyName = 'channel') 221 | where channel.propertyText like 'DiscordChannel %'; |] 222 | [] 223 | 224 | -- TODO(#200): document limitations of convertFridayVideos 225 | -- Special authorIds 226 | convertFridayVideos :: Connection -> IO () 227 | convertFridayVideos dbConn = 228 | executeNamed 229 | dbConn 230 | [sql|insert into FridayVideo (submissionText, 231 | submissionTime, 232 | authorId, 233 | authorDisplayName, 234 | watchedAt) 235 | select subText.propertyText, 236 | subDate.propertyUTCTime, 237 | 'Converted ' || author.propertyText, 238 | author.propertyText, 239 | watchedAt.propertyUTCTime 240 | from (select entityId, entityName 241 | from EntityProperty videos 242 | where entityName = 'FridayVideo' 243 | group by entityId) videos 244 | left join EntityProperty author 245 | on (author.entityId = videos.entityId and 246 | author.entityName = videos.entityName and 247 | author.propertyName = 'author') 248 | left join EntityProperty subDate 249 | on (subDate.entityId = videos.entityId and 250 | subDate.entityName = videos.entityName and 251 | subDate.propertyName = 'date') 252 | left join EntityProperty subText 253 | on (subText.entityId = videos.entityId and 254 | subText.entityName = videos.entityName and 255 | subText.propertyName = 'name') 256 | left join EntityProperty watchedAt 257 | on (watchedAt.entityId = videos.entityId and 258 | watchedAt.entityName = videos.entityName and 259 | watchedAt.propertyName = 'watchedAt'); |] 260 | [] 261 | 262 | main :: IO () 263 | main = do 264 | args <- getArgs 265 | case args of 266 | configPath:dbPath:_ -> do 267 | printf "[INFO] Configuration file: %s\n" configPath 268 | printf "[INFO] Database file: %s\n" dbPath 269 | potentialConfig <- eitherDecodeFileStrict configPath 270 | case configTwitch <$> potentialConfig of 271 | Right (Just config) -> do 272 | printf "[INFO] Backing up the database: %s -> %s.old\n" dbPath dbPath 273 | copyFile dbPath (dbPath ++ ".old") 274 | withConnection dbPath $ \dbConn -> 275 | withTransaction dbConn $ do 276 | manager <- TLS.newTlsManager 277 | putStrLn "[INFO] Preparing the migration table..." 278 | executeNamed dbConn [sql|DROP TABLE Migrations|] [] 279 | migrateDatabase dbConn kgbotkaMigrations 280 | executeNamed dbConn [sql|DROP TABLE EntityId|] [] 281 | putStrLn "[INFO] Populating HyperNerd builtin commands..." 282 | populateHyperNerdBuiltinCommands dbConn 283 | putStrLn "[INFO] Converting commands..." 284 | convertCommands dbConn 285 | putStrLn "[INFO] Converting aliases..." 286 | convertAliases dbConn 287 | putStrLn "[INFO] Converting Twitch logs..." 288 | convertTwitchLogs dbConn 289 | putStrLn "[INFO] Converting Discord logs..." 290 | convertDiscordLogs dbConn 291 | putStrLn "[INFO] Converting Friday videos..." 292 | convertFridayVideos dbConn 293 | putStrLn "[INFO] Converting Trusted users..." 294 | convertTrustedUsers dbConn manager config 295 | putStrLn "OK" 296 | Right Nothing -> 297 | error $ 298 | printf 299 | "[ERROR] Could not find twitch configuration in `%s`" 300 | configPath 301 | Left errorMessage -> error errorMessage 302 | _ -> error "Usage: MigrationTool " 303 | --------------------------------------------------------------------------------