├── Setup.hs ├── README.md ├── ChangeLog.md ├── test └── Spec.hs ├── .gitignore ├── app └── Main.hs ├── src ├── Commands.hs ├── Parser.hs ├── Queue.hs ├── YouTube.hs └── Cleiton.hs ├── cabal.project ├── LICENSE └── package.yaml /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # DJ Cleiton Rasta 2 | 3 | A self-hosted Discord music bot 4 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for dj-cleiton-rasta 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.secret 3 | dist-newstyle/ 4 | dj-cleiton-haskell.cabal 5 | hie.yaml 6 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Cleiton 4 | 5 | main :: IO () 6 | main = rasta 7 | -------------------------------------------------------------------------------- /src/Commands.hs: -------------------------------------------------------------------------------- 1 | module Commands where 2 | 3 | import Data.Text 4 | 5 | data T 6 | = Play Text 7 | | Remove Int 8 | | Skip 9 | | List 10 | deriving (Eq, Ord, Show) 11 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | 3 | source-repository-package 4 | type: git 5 | location: https://github.com/celsobonutti/discord-haskell.git 6 | tag: 0e073d3a8fcc2cd3d81b0c119dc23540d02a3467 7 | -------------------------------------------------------------------------------- /src/Parser.hs: -------------------------------------------------------------------------------- 1 | module Parser ( 2 | make, 3 | ) where 4 | 5 | import qualified Commands 6 | 7 | import Control.Monad.Combinators 8 | import Data.Text 9 | import Data.Void 10 | import Text.Megaparsec 11 | import Text.Megaparsec.Char 12 | import qualified Text.Megaparsec.Char.Lexer as Lexer 13 | 14 | type Parser = Parsec Void Text 15 | 16 | make :: Text -> Parser Commands.T 17 | make prefix = string prefix *> parseCommand 18 | 19 | parseCommand :: Parser Commands.T 20 | parseCommand = choice [parsePlay, parseRemove, parseSkip, parseList] 21 | 22 | parsePlay :: Parser Commands.T 23 | parsePlay = do 24 | _ <- string' "play" 25 | space1 26 | song <- pack <$> some anySingle 27 | return (Commands.Play song) 28 | 29 | parseRemove :: Parser Commands.T 30 | parseRemove = do 31 | _ <- string' "remove" 32 | space1 33 | Commands.Remove <$> Lexer.decimal 34 | 35 | parseSkip :: Parser Commands.T 36 | parseSkip = Commands.Skip <$ string' "skip" 37 | 38 | parseList :: Parser Commands.T 39 | parseList = Commands.List <$ string' "list" 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: dj-cleiton-haskell 2 | version: 0.1.0.0 3 | github: "celsobonutti/dj-cleiton-haskell" 4 | license: BSD3 5 | author: "Celso Bonutti" 6 | maintainer: "i.am@cel.so" 7 | copyright: "2021 Celso Bonutti" 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | description: Please see the README on GitHub at 14 | 15 | pkg-config-dependencies: 16 | - libsodium >= 1.0.13 17 | 18 | language: 19 | GHC2024 20 | 21 | dependencies: 22 | - base >= 4.16.0.0 && < 5 23 | # We used a git version of this one, pointing to the 9.10-support commit 24 | - discord-haskell 25 | - discord-haskell-voice >= 3.0.0 26 | - text >= 2.1 && < 3 27 | - unliftio >= 0.2.20 && < 0.3 28 | - megaparsec >= 9.1.0 && < 10 29 | - parser-combinators >= 1.3.0 && < 1.4.0 30 | - containers >= 0.6 && < 0.7 31 | - req >= 3.9 && < 4 32 | - aeson >= 2.0.3.0 && < 3.0 33 | - data-default >= 0.7 && < 0.8 34 | - mtl >= 2.2.2 && < 2.4 35 | 36 | library: 37 | source-dirs: src 38 | 39 | executables: 40 | dj-cleiton-haskell-exe: 41 | main: Main.hs 42 | source-dirs: app 43 | ghc-options: 44 | - -threaded 45 | - -rtsopts 46 | - -with-rtsopts=-N 47 | dependencies: 48 | - dj-cleiton-haskell 49 | 50 | tests: 51 | dj-cleiton-haskell-test: 52 | main: Spec.hs 53 | source-dirs: test 54 | ghc-options: 55 | - -threaded 56 | - -rtsopts 57 | - -with-rtsopts=-N 58 | dependencies: 59 | - dj-cleiton-haskell 60 | 61 | default-extensions: 62 | - OverloadedStrings 63 | - NamedFieldPuns 64 | - OverloadedRecordDot 65 | - DuplicateRecordFields 66 | -------------------------------------------------------------------------------- /src/Queue.hs: -------------------------------------------------------------------------------- 1 | module Queue where 2 | 3 | import Data.Default 4 | import Data.Foldable (toList) 5 | import Data.IORef 6 | import Data.Sequence (Seq (..)) 7 | import Data.Sequence qualified as Seq 8 | import Data.Text hiding ( 9 | Empty, 10 | intersperse, 11 | map, 12 | show, 13 | ) 14 | import Discord.Internal.Types.Embed 15 | import Prelude hiding (map, unlines) 16 | 17 | data Song = Song 18 | { title :: Text 19 | , videoId :: Text 20 | , description :: Text 21 | , thumbnail :: Text 22 | } 23 | deriving (Eq) 24 | 25 | newtype Queue = Queue {songs :: Seq Song} 26 | 27 | empty :: Queue 28 | empty = Queue Seq.empty 29 | 30 | map :: (Seq Song -> Seq Song) -> Queue -> Queue 31 | map f = Queue . f . songs 32 | 33 | addSong :: Song -> Queue -> Queue 34 | addSong song = map (:|> song) 35 | 36 | skip :: Queue -> (Queue, Maybe Song) 37 | skip Queue{songs = Empty} = (Queue Empty, Nothing) 38 | skip Queue{songs = (song :<| songs)} = (Queue songs, Just song) 39 | 40 | removeSongByIndex :: Int -> Queue -> Queue 41 | removeSongByIndex = map . Seq.deleteAt 42 | 43 | print :: Queue -> Text 44 | print = unlines . toList . Seq.mapWithIndex print . songs 45 | where 46 | print :: Int -> Song -> Text 47 | print index song = (pack . show . (+ 1) $ index) <> ". " <> title song 48 | 49 | toEmbed :: Song -> CreateEmbed 50 | toEmbed song = 51 | def 52 | { createEmbedTitle = title song 53 | , createEmbedDescription = description song 54 | , createEmbedUrl = "https://www.youtube.com/watch?v=" <> videoId song 55 | , createEmbedThumbnail = Just (CreateEmbedImageUrl . thumbnail $ song) 56 | } 57 | 58 | url :: Song -> String 59 | url song = "https://www.youtube.com/watch?v=" <> (unpack $ videoId song) 60 | -------------------------------------------------------------------------------- /src/YouTube.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE ExtendedDefaultRules #-} 3 | 4 | module YouTube where 5 | 6 | import Data.Aeson 7 | import Data.Text 8 | import Discord.Internal.Types.Embed 9 | import GHC.Generics 10 | import Network.HTTP.Req 11 | import qualified Queue 12 | import Prelude hiding (id) 13 | 14 | default (Text) 15 | 16 | fetch token query = 17 | req 18 | GET 19 | (https "youtube.googleapis.com" /: "youtube" /: "v3" /: "search") 20 | NoReqBody 21 | jsonResponse 22 | (options token query) 23 | 24 | options token query = 25 | ("key" =: token) 26 | <> ("part" =: "snippet") 27 | <> ("q" =: query) 28 | <> ("maxResults" =: "1") 29 | 30 | newtype VideoId = VideoId {videoId :: Text} deriving (Generic, Show) 31 | 32 | instance ToJSON VideoId where 33 | toEncoding = genericToEncoding defaultOptions 34 | 35 | instance FromJSON VideoId 36 | 37 | data VideoThumbnail = VideoThumbnail 38 | { url :: Text 39 | , width :: Int 40 | , height :: Int 41 | } 42 | deriving (Generic, Show) 43 | 44 | instance ToJSON VideoThumbnail where 45 | toEncoding = genericToEncoding defaultOptions 46 | 47 | instance FromJSON VideoThumbnail 48 | 49 | newtype VideoThumbnails = VideoThumbnails 50 | { medium :: VideoThumbnail 51 | } 52 | deriving (Generic, Show) 53 | 54 | instance ToJSON VideoThumbnails where 55 | toEncoding = genericToEncoding defaultOptions 56 | 57 | instance FromJSON VideoThumbnails 58 | 59 | data VideoSnippet = VideoSnippet 60 | { title :: Text 61 | , description :: Text 62 | , thumbnails :: VideoThumbnails 63 | } 64 | deriving (Generic, Show) 65 | 66 | instance ToJSON VideoSnippet where 67 | toEncoding = genericToEncoding defaultOptions 68 | 69 | instance FromJSON VideoSnippet 70 | 71 | data Video = Video 72 | { id :: VideoId 73 | , snippet :: VideoSnippet 74 | } 75 | deriving (Generic, Show) 76 | 77 | instance ToJSON Video where 78 | toEncoding = genericToEncoding defaultOptions 79 | 80 | instance FromJSON Video 81 | 82 | newtype Response = Response 83 | { items :: [Video] 84 | } 85 | deriving (Generic, Show) 86 | 87 | instance ToJSON Response where 88 | toEncoding = genericToEncoding defaultOptions 89 | 90 | instance FromJSON Response 91 | 92 | toSong :: Response -> Maybe Queue.Song 93 | toSong Response{items = []} = Nothing 94 | toSong Response{items = (song : _)} = 95 | Just 96 | ( Queue.Song 97 | { title = song.snippet.title 98 | , description = song.snippet.description 99 | , videoId = song.id.videoId 100 | , thumbnail = song.snippet.thumbnails.medium.url 101 | } 102 | ) 103 | -------------------------------------------------------------------------------- /src/Cleiton.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module Cleiton ( 4 | rasta, 5 | ) where 6 | 7 | import Commands 8 | import Control.Monad ( 9 | forM_, 10 | void, 11 | when, 12 | ) 13 | import Control.Monad.Reader 14 | import Data.Aeson 15 | import Data.IORef 16 | import Data.Text 17 | import Data.Text qualified as T 18 | import Data.Text.IO qualified as TIO 19 | import Discord 20 | import Discord qualified 21 | import Discord.Internal.Rest qualified as R 22 | import Discord.Internal.Rest.Voice qualified as Voice 23 | import Discord.Internal.Types.VoiceState 24 | import Discord.Requests qualified as R 25 | import Discord.Types 26 | import Discord.Voice 27 | import Network.HTTP.Req 28 | import Parser qualified 29 | import Queue (Queue) 30 | import Queue qualified 31 | import System.Environment (getEnv) 32 | import Text.Megaparsec (parseMaybe) 33 | import UnliftIO (liftIO) 34 | import UnliftIO.Concurrent 35 | import YouTube qualified 36 | import Prelude hiding (readFile) 37 | 38 | commandParser = Parser.make "λ" 39 | 40 | rasta :: IO () 41 | rasta = do 42 | queue <- newIORef Queue.empty 43 | tok <- pack <$> getEnv "DISCORD_TOKEN" 44 | youtubeToken <- pack <$> getEnv "YOUTUBE_TOKEN" 45 | 46 | TIO.putStrLn "Começando a debochar" 47 | 48 | t <- 49 | runDiscord $ 50 | def 51 | { discordToken = tok 52 | , discordOnStart = startHandler 53 | , discordOnEnd = liftIO $ TIO.putStrLn "Ended" 54 | , discordOnEvent = eventHandler queue youtubeToken 55 | , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn "" 56 | } 57 | TIO.putStrLn t 58 | 59 | startHandler :: DiscordHandler () 60 | startHandler = do 61 | Right partialGuilds <- restCall R.GetCurrentUserGuilds 62 | 63 | let activity = 64 | mkActivity "cleiton-rasta" ActivityTypeStreaming 65 | 66 | let opts = 67 | UpdateStatusOpts 68 | { updateStatusOptsSince = Nothing 69 | , updateStatusOptsActivities = [activity] 70 | , updateStatusOptsNewStatus = UpdateStatusOnline 71 | , updateStatusOptsAFK = False 72 | } 73 | sendCommand (UpdateStatus opts) 74 | 75 | eventHandler :: IORef Queue -> Text -> Event -> DiscordHandler () 76 | eventHandler queue youtubeToken event = case event of 77 | MessageCreate message -> do 78 | let channel = message.messageChannelId 79 | guildMember = message.messageMember 80 | sendMessage content = void $ restCall (R.CreateMessage channel content) 81 | case parseMaybe commandParser (message.messageContent) of 82 | Just (Play song) -> do 83 | case message.messageGuildId of 84 | Just guildId -> do 85 | voiceState <- restCall (Voice.GetUserVoiceState (message.messageAuthor.userId) guildId) 86 | liftIO $ print voiceState 87 | case voiceState of 88 | Right (VoiceState{voiceChannelId = Just channelId}) -> do 89 | addSong queue youtubeToken guildId channelId message.messageChannelId song 90 | Left _ -> sendMessage "Entra num canal de voz aí" 91 | Nothing -> sendMessage "Entra num canal de voz aí" 92 | Just List -> do 93 | queue <- liftIO . readIORef $ queue 94 | liftIO $ print message.messageMember 95 | sendMessage $ Queue.print queue 96 | Just Skip -> do 97 | result <- liftIO $ atomicModifyIORef' queue Queue.skip 98 | case result of 99 | Just removed -> sendMessage $ "Tirando: " <> Queue.title removed 100 | Nothing -> sendMessage "Tem música não porra" 101 | _ -> liftIO $ TIO.putStrLn message.messageContent 102 | _ -> return () 103 | 104 | addSong :: 105 | IORef Queue -> Text -> GuildId -> ChannelId -> ChannelId -> Text -> ReaderT DiscordHandle IO () 106 | addSong queue youtubeToken guild voiceChannelId textChannelId song = do 107 | request <- liftIO . runReq defaultHttpConfig $ YouTube.fetch youtubeToken song 108 | case YouTube.toSong . responseBody $ request of 109 | Just song -> do 110 | liftIO $ modifyIORef' queue (Queue.addSong song) 111 | newQueue <- liftIO . readIORef $ queue 112 | messageResult <- 113 | restCall 114 | ( R.CreateMessageDetailed 115 | textChannelId 116 | ( def 117 | { R.messageDetailedContent = "Bora debochar legal com" 118 | , R.messageDetailedEmbeds = Just [Queue.toEmbed song] 119 | } 120 | ) 121 | ) 122 | case messageResult of 123 | Right _ -> 124 | runVoice $ do 125 | resource <- createYoutubeResource (Queue.url song) Nothing 126 | case resource of 127 | Just res -> 128 | do 129 | leave <- join guild voiceChannelId 130 | play res UnknownCodec 131 | leave 132 | Nothing -> do 133 | liftDiscord $ 134 | void $ 135 | restCall 136 | (R.CreateMessage textChannelId "Deu ruim, essa porra existe mesmo?") 137 | Left _ -> 138 | void $ 139 | restCall 140 | (R.CreateMessage textChannelId "Deu ruim, essa porra existe mesmo?") 141 | Nothing -> 142 | void $ 143 | restCall 144 | (R.CreateMessage textChannelId "Deu ruim, essa porra existe mesmo?") 145 | --------------------------------------------------------------------------------