├── .gitignore ├── LICENSE ├── Main.hs ├── README.md ├── Setup.hs ├── intolerable-bot.cabal ├── rdota2.bayes ├── reply-learndota2.md ├── reply.md └── src ├── Args.hs ├── Bot.hs └── Control ├── Applicative └── Trans │ └── Either.hs └── Concurrent └── WriteSem.hs /.gitignore: -------------------------------------------------------------------------------- 1 | */.DS_Store 2 | *.yaml 3 | .cabal-sandbox 4 | cabal.sandbox.config 5 | dist/ 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Fraser Murray 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 Fraser Murray 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 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import qualified Bot 4 | 5 | main :: IO () 6 | main = Bot.main 7 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # intolerable-bot 2 | 3 | ## how to get it working 4 | 5 | 1. make sure you have a recent version of [cabal](http://www.haskell.org/cabal/) installed 6 | 2. clone this repo somewhere 7 | 3. clone the [`reddit`](https://github.com/intolerable/reddit) repo into `../reddit` (relative to this repo) 8 | 4. `cabal sandbox init` 9 | 5. `cabal sandbox add-source ../reddit` 10 | 6. `cabal install` 11 | 7. `.cabal-sandbox/bin/intolerable-bot USERNAME PASSWORD SUBREDDIT_NAME REPLY_FILE` like `intolerable-bot intolerable-bot $PASSWORD Dota2 reply.md` 12 | 13 | ## installing it to your global cabal installation 14 | 15 | 1. make sure you have a recent version of [cabal](http://www.haskell.org/cabal/) installed 16 | 2. clone this repo somewhere 17 | 3. clone the [`reddit`](https://github.com/intolerable/reddit) repo into `../reddit` (relative to this repo) 18 | 5. `cabal install ../reddit` 19 | 6. `cabal install` 20 | 7. `intolerable-bot USERNAME PASSWORD SUBREDDIT_NAME REPLY_FILE` (assuming your `cabal/bin` directory is in your `$PATH`) 21 | 22 | ## suggesting changes to the reply 23 | 24 | if you want to change the text for the original bot that runs on [/r/Dota2](http://reddit.com/r/Dota2), fork this repo, edit it, and send me a pull request 25 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /intolerable-bot.cabal: -------------------------------------------------------------------------------- 1 | name: intolerable-bot 2 | version: 0.2.0.0 3 | description: bot for posting helpful links to people who are new to Dota on reddit.com/r/Dota2 4 | license: BSD3 5 | license-file: LICENSE 6 | author: Fraser Murray 7 | maintainer: fraser.m.murray@gmail.com 8 | category: Web 9 | build-type: Simple 10 | cabal-version: >=1.10 11 | 12 | library 13 | exposed-modules: 14 | Bot 15 | other-modules: 16 | Args 17 | Control.Applicative.Trans.Either 18 | Control.Concurrent.WriteSem 19 | build-depends: 20 | base == 4.8.*, 21 | aeson, 22 | async, 23 | binary, 24 | bounded, 25 | containers, 26 | data-counter, 27 | data-default-class, 28 | naive-bayes, 29 | optparse-applicative, 30 | reddit, 31 | stm, 32 | text, 33 | time, 34 | transformers, 35 | yaml 36 | hs-source-dirs: src/ 37 | default-language: Haskell2010 38 | default-extensions: 39 | FlexibleContexts 40 | LambdaCase 41 | OverloadedStrings 42 | StandaloneDeriving 43 | UndecidableInstances 44 | ViewPatterns 45 | ghc-options: -Wall 46 | 47 | executable intolerable-bot 48 | main-is: Main.hs 49 | default-extensions: 50 | FlexibleContexts, 51 | OverloadedStrings 52 | build-depends: 53 | base == 4.8.*, 54 | intolerable-bot 55 | hs-source-dirs: ./ 56 | default-language: Haskell2010 57 | ghc-options: -Wall 58 | -------------------------------------------------------------------------------- /rdota2.bayes: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/intolerable/intolerable-bot/245f687ea8c6d7af5e74f412409bae4a75b816fb/rdota2.bayes -------------------------------------------------------------------------------- /reply-learndota2.md: -------------------------------------------------------------------------------- 1 | It looks like you're interested in learning to play Dota 2 or new to the game. Here are some useful resources which might help you get up to speed quickly with the game. 2 | 3 | *The subreddit has a wiki with a lot of useful information for newer players - from the sidebar: [**New players begin here!**](http://www.reddit.com/r/learndota2/wiki/index)* 4 | 5 | #### What are some basic tips when starting to play? 6 | 7 | The in-game tutorial (you will be prompted to try it when first joining the game, otherwise found under "Quests") will bring you up to speed on some of the basics on movement, combat, buying items, and more. 8 | 9 |   | Guides for beginners 10 | -----|------------ 11 | [Tutorial: How to Play Dota 2 In 4 Minutes](http://www.youtube.com/watch?v=akUNmFAzS98) | A brief video guide that will get you up to speed on all the basic components of a Dota 2 match. If you like to learn by doing and just get the basics, this is a great guide. 12 | [In-game guides for each hero](http://www.dota2.com/workshop/builds/overview) | You can subscribe to guides [in the Steam Workshop](http://steamcommunity.com/app/570/guides) and they will appear in-game with item and skill build recommendations. Reading the top-rated hero guide is often a good idea when playing a hero for the first time. 13 | [Comprehensive Guide to Dota 2](http://steamcommunity.com/sharedfiles/filedetails/?id=123364976) | An absolute guide to Dota 2 with a ton of video content, graphics and information. Might be a little overwhelming to a brand-new player. 14 | [Welcome to Dota, You Suck](https://purgegamers.true.io/g/dota-2-guide/) | A bit less all-encompassing, but will give you a great balance of the information you need to know. One of the most popular Dota guides. 15 | [Reddit's Dota 2 Hero Discussions](http://www.reddit.com/r/DotA2/search?q=title%3A%22Hero+Discussion+of+the+Day%22+is_self%3A1&restrict_sr=on&sort=new&t=all) | Reddit has run multiple discussion threads for every hero in Dota. Look back at them here. There are also [item discussions](http://www.reddit.com/r/DotA2/search?q=title%3A%22Item+Discussion+of+the+Day%22+is_self%3A1&restrict_sr=on&sort=new&t=all). 16 | [Dota for Dummies](http://www.youtube.com/playlist?list=PLWPOZNFdKVXsVqsMxlOa03GyXuiCTzhkR) | Dota for Dummies is an all inclusive video series that prepares you to jump into the world of Dota 2. Starting from the very basics then progressing forward, this series will help you get the foundation you need to become successful. 17 | [Switching from League of Legends?](http://www.teamliquid.net/forum/dota-2-strategy/423453-dota-2-for-lol-players) | While on the surface the games might seem similar, there are quite a lot of differences. This thread will give you a good idea of some of the major differences and tips specifically tailored towards players with experience in League of Legends. There's also a useful Reddit thread about the differences [here](http://www.reddit.com/r/DotA2/comments/otygb/switching_from_league_of_legends_what_should_i/). 18 | ["Which hero should I pick?"](http://www.reddit.com/r/DotA2/comments/10qbxo/i_finally_beat_the_bots_on_easy_i_suck_at_dota2/c6fraac) | This post outlines a few of the more beginner-friendly heroes and explains why they're good for newer players 19 | Other resources | [Dota 2 Wiki](http://dota2.gamepedia.com), [Liquipedia](http://wiki.teamliquid.net/dota2), [Weekly Stupid Questions Threads](http://www.reddit.com/r/DotA2/search?q=title%3A%22Weekly+Stupid+Questions%22&restrict_sr=on&sort=new&t=all) 20 | 21 | I'm a bot, but feel free to reply to me if you're having issues or if I get something wrong. If you have any suggestions for extra content to include, [message me](http://www.reddit.com/message/compose/?to=intolerable-bot) or check out my [github](https://github.com/intolerable/intolerable-bot). 22 | -------------------------------------------------------------------------------- /reply.md: -------------------------------------------------------------------------------- 1 | It looks like you're interested in learning to play Dota 2 or new to the game. Here are some useful resources which might help you get up to speed quickly with the game. 2 | 3 | *The subreddit has a wiki with a lot of useful information for newer players - from the sidebar: [**New to Dota 2? Start here.**](http://www.reddit.com/r/DotA2/wiki/faq#wiki_what_are_some_basic_tips_when_starting_to_play.3F)* 4 | 5 | #### What are some basic tips when starting to play? 6 | 7 | The in-game tutorial (you will be prompted to try it when first joining the game, otherwise found under "Quests") will bring you up to speed on some of the basics on movement, combat, buying items, and more. 8 | 9 |   | Guides for beginners 10 | -----|------------ 11 | [Tutorial: How to Play Dota 2 In 4 Minutes](http://www.youtube.com/watch?v=akUNmFAzS98) | A brief video guide that will get you up to speed on all the basic components of a Dota 2 match. If you like to learn by doing and just get the basics, this is a great guide. 12 | [In-game guides for each hero](http://www.dota2.com/workshop/builds/overview) | You can subscribe to guides [in the Steam Workshop](http://steamcommunity.com/app/570/guides) and they will appear in-game with item and skill build recommendations. Reading the top-rated hero guide is often a good idea when playing a hero for the first time. 13 | [Comprehensive Guide to Dota 2](http://steamcommunity.com/sharedfiles/filedetails/?id=123364976) | An absolute guide to Dota 2 with a ton of video content, graphics and information. Might be a little overwhelming to a brand-new player. 14 | [An introduction to player roles](https://www.youtube.com/playlist?list=PLxkyNsoBqOdBGfqZNbJwcz5UiL7rhrk3h) | A 5-part video series explaining the various team roles within Dota 2. 15 | [Welcome to Dota, You Suck](https://purgegamers.true.io/g/dota-2-guide/) | A bit less all-encompassing, but will give you a great balance of the information you need to know. One of the most popular Dota guides. 16 | [Reddit's Dota 2 Hero Discussions](http://www.reddit.com/r/DotA2/search?q=title%3A%22Hero+Discussion+of+the+Day%22+is_self%3A1&restrict_sr=on&sort=new&t=all) | Reddit has run multiple discussion threads for every hero in Dota. Look back at them here. There are also [item discussions](http://www.reddit.com/r/DotA2/search?q=title%3A%22Item+Discussion+of+the+Day%22+is_self%3A1&restrict_sr=on&sort=new&t=all). 17 | [Dota for Dummies](http://www.youtube.com/playlist?list=PLWPOZNFdKVXsVqsMxlOa03GyXuiCTzhkR) | Dota for Dummies is an all inclusive video series that prepares you to jump into the world of Dota 2. Starting from the very basics then progressing forward, this series will help you get the foundation you need to become successful. 18 | [Switching from League of Legends?](http://www.teamliquid.net/forum/dota-2-strategy/423453-dota-2-for-lol-players) | While on the surface the games might seem similar, there are quite a lot of differences. This thread will give you a good idea of some of the major differences and tips specifically tailored towards players with experience in League of Legends. There's also a useful Reddit thread about the differences [here](http://www.reddit.com/r/DotA2/comments/otygb/switching_from_league_of_legends_what_should_i/). 19 | ["Which hero should I pick?"](http://www.reddit.com/r/DotA2/comments/10qbxo/i_finally_beat_the_bots_on_easy_i_suck_at_dota2/c6fraac) | This post outlines a few of the more beginner-friendly heroes and explains why they're good for newer players 20 | Other resources | [Dota 2 Wiki](http://dota2.gamepedia.com), [Liquipedia](http://wiki.teamliquid.net/dota2), [Weekly Stupid Questions Threads](http://www.reddit.com/r/DotA2/search?q=title%3A%22Weekly+Stupid+Questions%22&restrict_sr=on&sort=new&t=all) 21 | 22 | I'm a bot, but feel free to reply to me if you're having issues or if I get something wrong. If you have any suggestions for extra content to include, [message me](http://www.reddit.com/message/compose/?to=intolerable-bot) or check out my [github](https://github.com/intolerable/intolerable-bot). 23 | -------------------------------------------------------------------------------- /src/Args.hs: -------------------------------------------------------------------------------- 1 | module Args 2 | ( optionsFromArgs 3 | , resolve 4 | , Config(..) 5 | , Options(..) 6 | , Settings(Settings) 7 | , Reply(..) 8 | , Bans(..) 9 | , Password 10 | , ReplyText 11 | , RefreshTime ) where 12 | 13 | import Control.Applicative 14 | import Data.Foldable 15 | import Data.Aeson 16 | import Data.Map (Map) 17 | import Data.Text (Text) 18 | import Reddit.Types.Subreddit 19 | import Reddit.Types.User 20 | import Options.Applicative 21 | import qualified Data.Map as Map 22 | 23 | type Password = Text 24 | type ReplyText = Text 25 | type RefreshTime = Int 26 | 27 | data Options = ConfigFile FilePath 28 | deriving (Show, Read, Eq) 29 | 30 | optionsFromArgs :: IO Options 31 | optionsFromArgs = 32 | execParser $ info (helper <*> options) description 33 | where 34 | description = mconcat 35 | [ fullDesc 36 | , header "intolerable-bot - Help new players on Reddit" ] 37 | 38 | options :: Parser Options 39 | options = ConfigFile <$> argument str (metavar "CONFIG" <> help "Config file to use") 40 | 41 | data Config = 42 | Config { defaultConfig :: Settings 43 | , subredditConfigs :: Map SubredditName Settings } 44 | deriving (Show, Read, Eq) 45 | 46 | instance FromJSON Config where 47 | parseJSON (Object o) = 48 | Config <$> parseJSON (Object o) 49 | <*> (Map.mapKeys R <$> o .: "subreddits") 50 | parseJSON _ = mempty 51 | 52 | data Settings = 53 | Settings { _username :: Maybe Username 54 | , _password :: Maybe Password 55 | , _reply :: Maybe Reply 56 | , _bans :: [Bans] 57 | , _refreshTime :: Maybe RefreshTime 58 | , _classifier :: Maybe FilePath 59 | , _useClassifier :: Bool 60 | , _verbose :: Maybe Bool } 61 | deriving (Show, Read, Eq) 62 | 63 | instance Monoid Settings where 64 | mempty = Settings Nothing Nothing Nothing [] Nothing Nothing False Nothing 65 | Settings u1 p1 r1 b1 t1 c1 x1 v1 `mappend` Settings u2 p2 r2 b2 t2 c2 x2 v2 = 66 | Settings (u1 <|> u2) (p1 <|> p2) (r1 <|> r2) (b1 <> b2) (t1 <|> t2) (c1 <|> c2) (x1 || x2) (v1 <|> v2) 67 | 68 | resolve :: Settings -> Map a Settings -> Map a Settings 69 | resolve x = fmap (x <>) 70 | 71 | instance FromJSON Settings where 72 | parseJSON (Object o) = 73 | Settings <$> (o .:? "username" <|> o .:? "user") 74 | <*> (o .:? "password" <|> o .:? "pass") 75 | <*> asum [ Just . ReplyLiteral <$> o .: "reply" 76 | , Just . ReplyFilePath <$> o .: "reply_file" 77 | , pure Nothing ] 78 | <*> parsedBans 79 | <*> asum [ o .:? "refresh" 80 | , o .:? "refresh_time" 81 | , o .:? "refresh_interval" ] 82 | <*> o .:? "classifier_file" 83 | <*> (o .: "use_classifier" <|> pure False) 84 | <*> o .:? "verbose" 85 | where 86 | parsedBans = 87 | mappend <$> (pure . BansList . map Username <$> (o .: "bans" <|> pure [])) 88 | <*> ((pure . BansFilePath <$> o .: "bans_file") <|> pure []) 89 | parseJSON Null = pure mempty 90 | parseJSON _ = mempty 91 | 92 | data Bans = BansList [Username] 93 | | BansFilePath FilePath 94 | deriving (Show, Read, Eq) 95 | 96 | data Reply = ReplyLiteral ReplyText 97 | | ReplyFilePath FilePath 98 | deriving (Show, Read, Eq) 99 | -------------------------------------------------------------------------------- /src/Bot.hs: -------------------------------------------------------------------------------- 1 | module Bot where 2 | 3 | import Args 4 | import Control.Applicative.Trans.Either 5 | import Control.Concurrent.WriteSem 6 | 7 | import Control.Concurrent 8 | import Control.Concurrent.Async 9 | import Control.Exception (catchJust) 10 | import Control.Monad 11 | import Control.Monad.IO.Class 12 | import Control.Monad.Trans.Class 13 | import Control.Monad.Trans.Reader 14 | import Data.Binary 15 | import Data.Char 16 | import Data.Classifier.NaiveBayes (NaiveBayes) 17 | import Data.Coerce 18 | import Data.Default.Class 19 | import Data.Function (fix) 20 | import Data.Maybe 21 | import Data.Monoid ((<>)) 22 | import Data.Text (Text) 23 | import Data.Time.Clock 24 | import Data.Time.Format 25 | import Data.Yaml 26 | import Reddit hiding (failWith, bans) 27 | import Reddit.Types.Comment (PostComments(..), CommentReference(..)) 28 | import Reddit.Types.Listing 29 | import Reddit.Types.Subreddit (SubredditName(..)) 30 | import Reddit.Types.User (Username(..)) 31 | import System.Exit 32 | import System.IO 33 | import System.IO.Error 34 | import qualified Data.Bounded.Set as Bounded 35 | import qualified Data.Classifier.NaiveBayes as NB 36 | import qualified Data.Counter as Counter 37 | import qualified Data.Map as Map 38 | import qualified Data.Text as Text 39 | import qualified Data.Text.IO as Text 40 | import qualified Reddit.Types.Comment as Comment 41 | import qualified Reddit.Types.Post as Post 42 | 43 | data ConcreteSettings = 44 | ConcreteSettings { username :: Username 45 | , password :: Password 46 | , subreddit :: SubredditName 47 | , replyText :: ReplyText 48 | , refreshTime :: RefreshTime 49 | , bans :: [Username] 50 | , classifier :: Maybe (NaiveBayes Bool Text) 51 | , useClassifier :: Bool 52 | , verboseOutput :: Bool } 53 | deriving (Show) 54 | 55 | main :: IO () 56 | main = do 57 | hSetBuffering stdout NoBuffering 58 | hSetBuffering stderr NoBuffering 59 | ConfigFile fp <- optionsFromArgs 60 | decodeFileEither fp >>= \case 61 | Left err -> do 62 | print err 63 | exitFailure 64 | Right (Config b m) -> do 65 | resolvedSettings <- mapM confirm $ resolve b m 66 | let (lefts, rights) = Map.mapEither id resolvedSettings 67 | if Map.null lefts 68 | then do 69 | sem <- newWriteSemIO 70 | void $ mapConcurrently (\(k, s) -> run sem (s k)) $ Map.toList rights 71 | else do 72 | Map.foldrWithKey handleError (return ()) lefts 73 | exitFailure 74 | 75 | handleError :: SubredditName -> [Text] -> IO () -> IO () 76 | handleError (R r) errs m = m >> do 77 | Text.putStrLn $ pluralize errs "Error" <> " with settings for subreddit /r/" <> r <> ":" 78 | forM_ errs $ \err -> 79 | Text.putStr $ " - " <> err 80 | 81 | pluralize :: [a] -> Text -> Text 82 | pluralize [_] x = x 83 | pluralize _ x = x <> "s" 84 | 85 | confirm :: Settings -> IO (Either [Text] (SubredditName -> ConcreteSettings)) 86 | confirm (Settings u p r b t c x v) = 87 | runEitherA $ 88 | subredditLastSettings 89 | <$> justOr ["Missing username"] u 90 | <*> justOr ["Missing password"] p 91 | <*> loadReply r 92 | <*> pure (fromMaybe 5 t) 93 | <*> loadBans b 94 | <*> sequenceA (fmap loadClassifier c) 95 | <*> pure x 96 | <*> pure (fromMaybe False v) 97 | 98 | subredditLastSettings :: Username -> Password -> ReplyText -> RefreshTime -> [Username] -> Maybe (NaiveBayes Bool Text) -> Bool -> Bool -> SubredditName -> ConcreteSettings 99 | subredditLastSettings u p r t b n x v s = ConcreteSettings u p s r t b n x v 100 | 101 | loadBans :: [Bans] -> EitherA [Text] IO [Username] 102 | loadBans = fmap concat . sequenceA . map f 103 | where 104 | f (BansList us) = pure us 105 | f (BansFilePath fp) = EitherA $ 106 | decodeFileEither fp >>= \case 107 | Left err -> return $ Left [Text.pack $ show err] 108 | Right xs -> return $ Right $ map Username xs 109 | 110 | loadReply :: Maybe Reply -> EitherA [Text] IO ReplyText 111 | loadReply x = case x of 112 | Just r -> case r of 113 | ReplyLiteral lit -> pure lit 114 | ReplyFilePath fp -> readReplyFile fp 115 | Nothing -> failWith ["Missing reply"] 116 | 117 | readReplyFile :: FilePath -> EitherA [Text] IO ReplyText 118 | readReplyFile fp = EitherA $ catchJust f (Right <$> Text.readFile fp) (return . Left . return) 119 | where 120 | f (isDoesNotExistError -> True) = Just "Reply file does not exist" 121 | f (isPermissionError -> True) = Just "Incorrect permissions for reply file" 122 | f _ = Nothing 123 | 124 | loadClassifier :: FilePath -> EitherA [Text] IO (NaiveBayes Bool Text) 125 | loadClassifier fp = EitherA $ f <$> decodeFileOrFail fp 126 | where 127 | f (Left _) = Left ["Classifier could not be read"] 128 | f (Right x) = pure x 129 | 130 | run :: WriteSem -> ConcreteSettings -> IO () 131 | run sem settings = 132 | withAsync (loopWith (forever $ commentsLoop sem) sem settings) $ \c -> 133 | case classifier settings of 134 | Just _ -> 135 | withAsync (loopWith (forever $ postsLoop sem) sem settings) $ \p -> 136 | void $ waitBoth c p 137 | Nothing -> wait c 138 | 139 | loopWith :: RedditT (ReaderT ConcreteSettings IO) () -> WriteSem -> ConcreteSettings -> IO () 140 | loopWith act sem settings = do 141 | res <- flip runReaderT settings $ 142 | runResumeRedditWith def { customUserAgent = Just "intolerable-bot v0.1.0.0" 143 | , loginMethod = Credentials (coerce (username settings)) (password settings) 144 | , rateLimitingEnabled = False } act 145 | case res of 146 | Left (APIError CredentialsError, _) -> 147 | withWriteSem sem $ 148 | Text.putStrLn $ "Username / password details incorrect for /r/" <> coerce (subreddit settings) 149 | Left (err, Nothing) -> do 150 | liftIO $ print err 151 | (5 * refreshTime settings) `seconds` threadDelay 152 | loopWith act sem settings 153 | Left (err, Just resume) -> do 154 | liftIO $ print err 155 | loopWith resume sem settings 156 | Right () -> return () 157 | 158 | postsLoop :: WriteSem -> RedditT (ReaderT ConcreteSettings IO) () 159 | postsLoop sem = do 160 | u <- lift $ asks username 161 | r <- lift $ asks subreddit 162 | t <- lift $ asks refreshTime 163 | rt <- lift $ asks replyText 164 | cls <- lift $ asks (fromJust . classifier) 165 | use <- lift $ asks useClassifier 166 | withInitial (Bounded.empty 500) $ \loop set -> do 167 | Listing _ _ ps <- getPosts' (Options Nothing (Just 100)) New (Just r) 168 | writeLogEntry sem r "got listing" 169 | let news = filter (\x -> not $ Bounded.member (Post.postID x) set) ps 170 | forM_ news $ \p -> 171 | unless (Post.author p == u) $ 172 | case Post.content p of 173 | Post.SelfPost m _ -> do 174 | let c = Counter.fromList $ process m 175 | case NB.test cls c of 176 | Just True -> 177 | if use 178 | then do 179 | PostComments _ cs <- getPostComments $ Post.postID p 180 | actuals <- resolveComments (Post.postID p) cs 181 | unless (any ((== u) . Comment.author) actuals) $ do 182 | botReply <- reply p rt 183 | writeLogEntry sem r $ mconcat 184 | [ "Auto-responded to " 185 | , coerce $ Post.postID p 186 | , " (" 187 | , coerce botReply 188 | , ")" ] 189 | else 190 | writeLogEntry sem r $ mconcat 191 | [ "Possible AI match @ " 192 | , coerce $ Post.postID p ] 193 | _ -> return () 194 | _ -> return () 195 | unless (null news) $ writeLogEntry sem r "got listing" 196 | t `seconds` threadDelay 197 | loop $ Bounded.insertAll (Post.postID <$> news) set 198 | 199 | commentsLoop :: WriteSem -> RedditT (ReaderT ConcreteSettings IO) () 200 | commentsLoop sem = do 201 | r <- lift $ asks subreddit 202 | t <- lift $ asks refreshTime 203 | withInitial (Bounded.empty 500) $ \loop set -> do 204 | Listing _ _ cs <- getNewComments' (Options Nothing (Just 100)) (Just r) 205 | let news = filter (\x -> not $ Bounded.member (Comment.commentID x) set) cs 206 | mapM_ (commentResponder sem) news 207 | unless (null news) $ writeLogEntry sem r "dealt with new comments" 208 | t `seconds` threadDelay 209 | loop $ Bounded.insertAll (Comment.commentID <$> news) set 210 | 211 | commentResponder :: WriteSem -> Comment -> RedditT (ReaderT ConcreteSettings IO) () 212 | commentResponder sem c = do 213 | u <- lift $ asks username 214 | r <- lift $ asks subreddit 215 | rt <- lift $ asks replyText 216 | bs <- lift $ asks bans 217 | when (shouldRespond u (Comment.body c)) $ 218 | unless (Comment.author c `elem` bs) $ do 219 | writeLogEntry sem r "found a comment" 220 | (selfpost, sibs) <- getSiblingComments c 221 | unless (any ((== u) . Comment.author) sibs) $ do 222 | writeLogEntry sem r $ "found a comment we didn't already respond to: " <> coerce (Comment.commentID c) 223 | case Comment.inReplyTo c of 224 | Just parentComment -> reply parentComment rt >>= logReply r 225 | Nothing -> 226 | when selfpost $ 227 | reply (Comment.parentLink c) rt >>= logReply r 228 | where 229 | logReply r botReply = writeLogEntry sem r $ mconcat 230 | [ "Responded to " 231 | , coerce (Comment.commentID c) 232 | , " by " 233 | , coerce (Comment.author c) 234 | , " (" 235 | , coerce botReply 236 | , ")" ] 237 | 238 | getSiblingComments :: MonadIO m => Comment -> RedditT m (Bool, [Comment]) 239 | getSiblingComments c = do 240 | let parent = Comment.parentLink c 241 | PostComments p cs <- 242 | case Comment.inReplyTo c of 243 | Just parentComment -> 244 | getPostSubComments parent parentComment >>= \case 245 | PostComments p (com:_) -> do 246 | Listing _ _ cs <- mconcat <$> map Comment.replies <$> resolveComments parent [com] 247 | return $ PostComments p cs 248 | x -> return x 249 | Nothing -> getPostComments parent 250 | case Post.content p of 251 | Post.SelfPost _ _ -> (,) True <$> resolveComments parent cs 252 | _ -> (,) (isJust (Comment.inReplyTo c)) <$> resolveComments parent cs 253 | 254 | resolveComments :: MonadIO m => PostID -> [CommentReference] -> RedditT m [Comment] 255 | resolveComments p refs = concat <$> mapM f refs 256 | where 257 | f (Actual c) = return [c] 258 | f (Reference _ cs) = do 259 | moreComments <- getMoreChildren p cs 260 | resolveComments p moreComments 261 | 262 | shouldRespond :: Username -> Text -> Bool 263 | shouldRespond (Username u) = Text.isInfixOf (Text.toCaseFold $ "u/" <> u) . Text.toCaseFold 264 | 265 | withInitial :: a -> ((a -> b) -> a -> b) -> b 266 | withInitial = flip fix 267 | 268 | seconds :: MonadIO m => Int -> (Int -> IO ()) -> m () 269 | n `seconds` f = liftIO $ f $ n * 1000000 270 | 271 | writeLogEntry :: MonadIO m => WriteSem -> SubredditName -> Text -> m () 272 | writeLogEntry sem (R r) t = do 273 | time <- liftIO getCurrentTime 274 | let space = " " 275 | withWriteSem sem $ 276 | mapM_ Text.putStr 277 | [ makeTime time 278 | , space 279 | , "/r/" 280 | , r 281 | , ": " 282 | , t 283 | , "\n" ] 284 | 285 | makeTime :: UTCTime -> Text 286 | makeTime t = Text.pack $ formatTime defaultTimeLocale (iso8601DateFormat (Just "%H:%M:%S")) t 287 | 288 | process :: Text -> [Text] 289 | process = filter (not . Text.null) . 290 | map (Text.map toLower . Text.filter isAlpha) . 291 | concatMap (Text.splitOn ".") . 292 | Text.splitOn " " . 293 | Text.filter (not . (== '-')) 294 | -------------------------------------------------------------------------------- /src/Control/Applicative/Trans/Either.hs: -------------------------------------------------------------------------------- 1 | module Control.Applicative.Trans.Either 2 | ( EitherA(..) 3 | , failWith 4 | , justOr ) where 5 | 6 | import Control.Applicative 7 | 8 | newtype EitherA e f a = EitherA { runEitherA :: f (Either e a) } 9 | 10 | deriving instance Show (f (Either e a)) => Show (EitherA e f a) 11 | deriving instance Read (f (Either e a)) => Read (EitherA e f a) 12 | deriving instance Eq (f (Either e a)) => Eq (EitherA e f a) 13 | deriving instance Ord (f (Either e a)) => Ord (EitherA e f a) 14 | 15 | instance Functor f => Functor (EitherA e f) where 16 | fmap f (EitherA x) = EitherA (fmap (fmap f) x) 17 | 18 | instance (Monoid e, Applicative f) => Applicative (EitherA e f) where 19 | pure = EitherA . pure . Right 20 | EitherA f <*> EitherA x = EitherA (combine <$> f <*> x) 21 | 22 | instance (Monoid e, Alternative f) => Alternative (EitherA e f) where 23 | empty = EitherA empty 24 | EitherA x <|> EitherA y = EitherA (alternative <$> x <*> y) 25 | 26 | instance (Monoid e, Alternative f) => Monoid (EitherA e f a) where 27 | mempty = empty 28 | mappend = (<|>) 29 | 30 | combine :: Monoid a => Either a (b -> c) -> Either a b -> Either a c 31 | combine (Left x) (Left y) = Left (x `mappend` y) 32 | combine (Left x) _ = Left x 33 | combine _ (Left y) = Left y 34 | combine (Right g) (Right y) = Right (g y) 35 | 36 | alternative :: Monoid a => Either a b -> Either a b -> Either a b 37 | alternative (Right x) _ = Right x 38 | alternative (Left _) (Right x) = Right x 39 | alternative (Left x) (Left y) = Left (x `mappend` y) 40 | 41 | failWith :: Applicative f => e -> EitherA e f a 42 | failWith = EitherA . pure . Left 43 | 44 | justOr :: (Applicative f, Monoid e) => e -> Maybe a -> EitherA e f a 45 | justOr m = maybe (failWith m) pure 46 | -------------------------------------------------------------------------------- /src/Control/Concurrent/WriteSem.hs: -------------------------------------------------------------------------------- 1 | module Control.Concurrent.WriteSem 2 | ( WriteSem 3 | , newWriteSem 4 | , newWriteSemIO 5 | , withWriteSem ) where 6 | 7 | import Control.Monad.STM 8 | import Control.Concurrent.STM.TVar 9 | import Control.Monad.IO.Class 10 | import Control.Exception 11 | 12 | newtype WriteSem = WriteSem (TVar Bool) 13 | 14 | newWriteSem :: STM WriteSem 15 | newWriteSem = WriteSem <$> newTVar True 16 | 17 | newWriteSemIO :: IO WriteSem 18 | newWriteSemIO = WriteSem <$> newTVarIO True 19 | 20 | waitWriteSem :: WriteSem -> STM () 21 | waitWriteSem (WriteSem t) = 22 | readTVar t >>= \case 23 | True -> 24 | writeTVar t False 25 | False -> retry 26 | 27 | signalWriteSem :: WriteSem -> STM () 28 | signalWriteSem (WriteSem t) = 29 | readTVar t >>= \case 30 | False -> 31 | writeTVar t True 32 | True -> retry 33 | 34 | withWriteSem :: MonadIO m => WriteSem -> IO a -> m a 35 | withWriteSem sem act = liftIO $ 36 | bracket_ 37 | (atomically $ waitWriteSem sem) 38 | (atomically $ signalWriteSem sem) 39 | act 40 | --------------------------------------------------------------------------------