├── .gitignore ├── LICENSE ├── Procfile ├── README.md ├── Setup.hs ├── app.json ├── slantbot.cabal └── src ├── Algolia ├── Query.hs └── Response.hs ├── Main.hs └── Slantbot ├── Algolia.hs ├── Config.hs ├── Reddit.hs └── Reddit ├── Config.hs ├── Messages.hs ├── Monad.hs ├── Subreddits.hs └── Subreddits ├── Permissions.hs └── Responses.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox/ 2 | cabal.sandbox.config 3 | dist/ 4 | reddit/dist/ 5 | scratch/ 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2015 Parli, Inc. 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | -------------------------------------------------------------------------------- /Procfile: -------------------------------------------------------------------------------- 1 | worker: bin/slantbot -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Slantbot 2 | 3 | Slantbot scans a list of approved subreddits searching for comments starting with its invocation command, for example `@whatarethebest Q&A websites for subjective questions`. Queries are harvested from the first line of such comments, and forwarded to Slant.co's search interface. Results are parsed, formatted and returned as a reply to the triggering comment. Additionally, it forwards any direct messages it receives to a maintainer's account. The subreddit list is read in from a remote SQL database; other configuration (usernames, API codes, etc.) are provided through environment variables. 4 | 5 | The code is modular and extensible, and many parts could be useful to other projects. 6 | 7 | - The actions performed within a subreddit are separate from the scanning mechanism, so the "skeleton" of Slantbot can be used for basically any reddit bot. In any case, it uses the Haskell [reddit library](https://hackage.haskell.org/package/reddit) and should serve as good example code for that. 8 | 9 | - While the Algolia query composition is merely "good enough", the associated JSON results parser is generic, and complete as far as I've been able to discover, needing only a schema for the user data (which can be partial). 10 | 11 | - `Main.hs` is generic even beyond the bot: it reads in configuration, then spawns a list of threads, which currently happens to be a singleton list of just the reddit bot, but could be anything (commented lines there hint at a future plan). Anyone curious about threads in Haskell should take a look, because it's almost embarrassingly simple. :) 12 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /app.json: -------------------------------------------------------------------------------- 1 | { 2 | "env": { 3 | "HALCYON_NO_BUILD_DEPENDENCIES": { 4 | "description": "Force haskell-on-heroku to build everything at once.", 5 | "value": "0" 6 | }, 7 | "HALCYON_GHC_VERSION": { 8 | "description": "Override default v7.8.4. Hooray, no Control.Applicative imports!", 9 | "value": "7.10.1" 10 | }, 11 | "HALCYON_CABAL_VERSION": { 12 | "description": "Override default v1.20.0.3 for compatibility with GHC 7.10.", 13 | "value": "1.22.6.0" 14 | }, 15 | "ALGOLIA_ID": { 16 | "description": "Application ID for Algolia search service." 17 | }, 18 | "ALGOLIA_KEY": { 19 | "description": "API key for Algolia search service." 20 | }, 21 | "ALGOLIA_QUERY_BASE": { 22 | "description": "Parameters for Algolia searches. This is everything between ? and &query= in the REST query.", 23 | }, 24 | "ALGOLIA_QUERY_INDEX": { 25 | "description": "Algolia application index to query. Setting this to * should work, but is untested.", 26 | }, 27 | "DATABASE_URL": { 28 | "description": "URL for subreddit permissions database. It needs a table named 'subreddits' with columns varchar(22):'subreddit' and bool:'auto'.", 29 | }, 30 | "REDDIT_FREQ": { 31 | "description": "Reddit scan frequency in seconds.", 32 | "value": "20" 33 | }, 34 | "REDDIT_OWNER": { 35 | "description": "Reddit user to receive direct mail sent to the bot. Note: No mail will be forwarded until the bot's account no longer needs a captcha.", 36 | }, 37 | "REDDIT_PASS": { 38 | "description": "Password for the bot's reddit account.", 39 | }, 40 | "REDDIT_USER": { 41 | "description": "Reddit username for the bot.", 42 | }, 43 | }, 44 | "addons": [ 45 | "heroku-postgresql" 46 | ], 47 | "buildpacks": [ 48 | { 49 | "url": "https://github.com/mietek/haskell-on-heroku" 50 | } 51 | ] 52 | } -------------------------------------------------------------------------------- /slantbot.cabal: -------------------------------------------------------------------------------- 1 | -- Initial slantbot.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: slantbot 5 | version: 0.1.1.0 6 | -- synopsis: 7 | -- description: 8 | -- license: 9 | -- license-file: 10 | author: tejon@slant.co 11 | maintainer: tejon@slant.co 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable slantbot 19 | main-is: Main.hs 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: 23 | aeson >= 0.8 && < 0.10, 24 | async == 2.0.*, 25 | base >= 4.6 && < 4.9, 26 | bytestring == 0.10.*, 27 | connection == 0.2.*, 28 | data-default == 0.5.*, 29 | http-conduit == 2.1.7.2, 30 | mtl == 2.2.*, 31 | network-uri == 2.6.*, 32 | postgresql-simple == 0.4.*, 33 | reddit >= 0.1.1 && < 0.2, 34 | transformers == 0.4.*, 35 | text == 1.2.* 36 | hs-source-dirs: src 37 | default-language: Haskell2010 38 | default-extensions: 39 | FlexibleInstances 40 | OverloadedStrings 41 | GHC-options: -O2 42 | -------------------------------------------------------------------------------- /src/Algolia/Query.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Algolia.Query (AlgoliaProfile(..), algoliaQuery) where 4 | 5 | -- TODO: this all less bad 6 | 7 | import Algolia.Response (AlgoliaResponse) 8 | import Control.Exception 9 | import Data.Aeson 10 | import Data.ByteString (ByteString) 11 | import Data.ByteString.Char8 (pack) 12 | import qualified Data.ByteString.Lazy as L (ByteString) 13 | import Data.Default 14 | import Data.List 15 | import Data.Monoid 16 | import Network.HTTP.Conduit 17 | import Network.URI (escapeURIString, 18 | isUnescapedInURIComponent) 19 | 20 | data AlgoliaProfile = AlgoliaProfile 21 | { appID :: !ByteString 22 | , apiKey :: !ByteString 23 | , baseQuery :: !ByteString 24 | , queryIndex :: !ByteString 25 | , manager :: !Manager 26 | } 27 | instance Show AlgoliaProfile where 28 | show x = 29 | "AlgoliaProfile {appID = " ++ show (appID x) 30 | ++ ", apiKey = " ++ show (apiKey x) 31 | ++ ", baseQuery = " ++ show (baseQuery x) 32 | ++ ", queryIndex = " ++ show (queryIndex x) 33 | ++ ", manager = }" 34 | 35 | algoliaQuery :: FromJSON a 36 | => (String -> String) 37 | -> ([String] -> [String]) 38 | -> AlgoliaProfile 39 | -> String 40 | -> IO (Maybe (AlgoliaResponse a)) 41 | algoliaQuery groomChars groomWords profile query = do 42 | response <- runQuery (mkQuery groomChars groomWords profile query) 43 | $ manager profile 44 | return $ case response of 45 | Right r -> go $ responseBody r 46 | _ -> Nothing 47 | where 48 | go r = case decode r of 49 | Nothing -> Nothing 50 | x -> x 51 | 52 | mkQuery :: (String -> String) 53 | -> ([String] -> [String]) 54 | -> AlgoliaProfile 55 | -> String 56 | -> Request 57 | mkQuery gC gW p q' = 58 | let q = ("&query=" <>) . pack . intercalate "+" 59 | . fmap (escapeURIString isUnescapedInURIComponent) 60 | . gW . words . gC $ q' 61 | in def { method = "POST" 62 | , host = appID p <> "-dsn.algolia.net" 63 | , path = "/1/indexes/" <> (queryIndex p) <> "/query" 64 | , requestHeaders = [ ("X-Algolia-Application-Id", appID p) 65 | , ("X-Algolia-API-Key", apiKey p) ] 66 | , requestBody = RequestBodyBS $ "{ \"params\" : \"" 67 | <> (baseQuery p) <> q <> "\" }" 68 | } 69 | 70 | runQuery :: Request 71 | -> Manager 72 | -> IO (Either HttpException (Response L.ByteString)) 73 | runQuery r m = try $ httpLbs r m 74 | -------------------------------------------------------------------------------- /src/Algolia/Response.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Algolia.Response where 4 | 5 | import Data.Aeson 6 | import Data.Aeson.TH 7 | import Data.Text (Text) 8 | 9 | data AlgoliaResponse a = AlgoliaResponse 10 | { hits :: ![AlgoliaHit a] 11 | , nbHits :: !Int 12 | , page :: !Int 13 | , nbPages :: !Int 14 | , hitsPerPage :: !Int 15 | , processingTimeMS :: !Int 16 | , query :: !Text 17 | , params :: !Text 18 | , queryAfterRemoval :: !(Maybe Text) 19 | , parsedQuery :: !(Maybe Text) 20 | , index :: !(Maybe Text) 21 | , serverUsed :: !(Maybe Text) 22 | , timeoutCounts :: !(Maybe Bool) 23 | , timeoutHits :: !(Maybe Bool) 24 | } deriving (Show) 25 | -- Can't derive this; probably because of weirdness in AlgoliaHit. 26 | instance (FromJSON a) => FromJSON (AlgoliaResponse a) where 27 | parseJSON (Object v) = AlgoliaResponse 28 | <$> v.:"hits" 29 | <*> v.:"nbHits" 30 | <*> v.:"page" 31 | <*> v.:"nbPages" 32 | <*> v.:"hitsPerPage" 33 | <*> v.:"processingTimeMS" 34 | <*> v.:"query" 35 | <*> v.:"params" 36 | <*> v.:?"queryAfterRemoval" 37 | <*> v.:?"parsedQuery" 38 | <*> v.:?"index" 39 | <*> v.:?"serverUsed" 40 | <*> v.:?"timeoutCounts" 41 | <*> v.:?"timeoutHits" 42 | parseJSON _ = mempty 43 | 44 | data AlgoliaHit a = AlgoliaHit 45 | { rankingInfo :: !(Maybe AlgoliaRankingInfo) 46 | , userData :: !a 47 | } deriving (Show) 48 | -- Algolia stuffs the optional ranking info INSIDE the user-data object... 49 | instance (FromJSON a) => FromJSON (AlgoliaHit a) where 50 | parseJSON o@(Object v) = AlgoliaHit 51 | <$> v.:?"_rankingInfo" 52 | <*> parseJSON o 53 | parseJSON _ = mempty 54 | 55 | data AlgoliaRankingInfo = AlgoliaRankingInfo 56 | { nbTypos :: !Int 57 | , firstMatchedWord :: !Int 58 | , proximityDistance :: !Int 59 | , userScore :: !Int 60 | , geoDistance :: !Int 61 | , geoPrecision :: !Int 62 | , nbExactWords :: !Int 63 | , words :: !Int 64 | } deriving (Show) 65 | $(deriveJSON defaultOptions ''AlgoliaRankingInfo) 66 | -------------------------------------------------------------------------------- /src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Concurrent.Async 4 | import Slantbot.Config 5 | import qualified Slantbot.Reddit as Reddit 6 | -- import qualified Slantbot.Twitter as Twitter 7 | 8 | main :: IO () 9 | main = do 10 | config <- getConfig 11 | threads <- mapM async 12 | [ Reddit.runBot $ reddit config 13 | -- , Twitter.runBot $ twitter config 14 | ] 15 | mapM_ wait threads 16 | -------------------------------------------------------------------------------- /src/Slantbot/Algolia.hs: -------------------------------------------------------------------------------- 1 | module Slantbot.Algolia where 2 | 3 | import Algolia.Query 4 | import Algolia.Response 5 | import Data.Aeson 6 | import Data.Char 7 | import Data.Maybe 8 | import Data.Text (Text) 9 | 10 | questionSearch :: AlgoliaProfile -> String -> IO (Maybe Question) 11 | questionSearch _ [] = return Nothing 12 | questionSearch profile q = do 13 | response <- algoliaQuery groomChars groomWords profile q 14 | return $ case response of 15 | Just r -> userData <$> (listToMaybe . hits $ r) 16 | _ -> Nothing 17 | where 18 | groomChars = fmap toLower . filter (not . (=='?')) 19 | groomWords = filter $ not . flip elem 20 | [ "", "what", "are", "is", "the", "best", "a" 21 | , "an", "for", "in", "of", "on", "to", "with" ] 22 | 23 | -- TODO: More complete schemas; also perhaps a dash of lens. 24 | data Question = Question 25 | { questionID :: !Int 26 | , questionVotes :: !Int 27 | , questionTitle :: !Text 28 | , questionOptions :: ![Option] 29 | } deriving (Eq, Show) 30 | instance FromJSON Question where 31 | parseJSON (Object v) = Question 32 | <$> v.:"id" 33 | <*> v.:"totalVotes" 34 | <*> (v.:"revision" >>= (.:"title")) 35 | <*> (v.:"viewpoints" >>= (.:"children")) 36 | parseJSON _ = mempty 37 | 38 | data Option = Option 39 | { optionID :: !Int 40 | , optionVotes :: !Int 41 | , optionTitle :: !Text 42 | , optionGet :: !Text 43 | } deriving (Eq, Show) 44 | instance FromJSON Option where 45 | parseJSON (Object v) = Option 46 | <$> v.:"id" 47 | <*> (v.:"votes" >>= (.:"count")) 48 | <*> (v.:"revision" >>= (.:"title")) 49 | <*> (v.:"revision" >>= (.:"siteURL")) 50 | parseJSON _ = mempty 51 | -------------------------------------------------------------------------------- /src/Slantbot/Config.hs: -------------------------------------------------------------------------------- 1 | module Slantbot.Config where 2 | 3 | import Algolia.Query 4 | import Control.Monad 5 | import qualified Data.ByteString.Char8 as B 6 | import Data.Default 7 | import qualified Data.Text as T 8 | import Network.Connection 9 | import Network.HTTP.Conduit 10 | import Reddit 11 | import Slantbot.Reddit.Config 12 | import System.Environment 13 | 14 | data Config = Config 15 | { reddit :: !RedditConfig 16 | -- , twitter :: !TwitterConfig 17 | } deriving (Show) 18 | 19 | getConfig :: IO Config 20 | getConfig = do 21 | let 22 | tEnv = liftM T.pack . getEnv 23 | bEnv = liftM B.pack . getEnv 24 | algid <- bEnv "ALGOLIA_ID" 25 | algky <- bEnv "ALGOLIA_KEY" 26 | algqb <- bEnv "ALGOLIA_QUERY_BASE" 27 | algix <- bEnv "ALGOLIA_QUERY_INDEX" 28 | dburl <- bEnv "DATABASE_URL" 29 | owner <- tEnv "REDDIT_OWNER" 30 | ruser <- tEnv "REDDIT_USER" 31 | rpass <- tEnv "REDDIT_PASS" 32 | rfreq <- (1000000*).read <$> getEnv "REDDIT_FREQ" 33 | httpM <- newManager 34 | $ mkManagerSettings (TLSSettingsSimple True False False) Nothing 35 | let 36 | aprof = AlgoliaProfile algid algky algqb algix httpM 37 | rinfo = RedditInfo aprof dburl (Username owner) (Username ruser) 38 | ropts = def { connectionManager = Just httpM 39 | , loginMethod = Credentials ruser rpass } 40 | rconf = RedditConfig rinfo rfreq ropts 41 | return $ Config rconf --tconf 42 | -------------------------------------------------------------------------------- /src/Slantbot/Reddit.hs: -------------------------------------------------------------------------------- 1 | module Slantbot.Reddit (runBot) where 2 | 3 | import Control.Concurrent 4 | import Control.Monad 5 | import Control.Monad.Reader 6 | import Reddit 7 | import Slantbot.Reddit.Config 8 | import Slantbot.Reddit.Messages 9 | import Slantbot.Reddit.Monad 10 | import Slantbot.Reddit.Subreddits 11 | 12 | runBot :: RedditConfig -> IO () 13 | runBot config@(RedditConfig info freq opts) = do 14 | _ <- runReaderT (runRedditWith opts bot) info 15 | when (freq > 0) $ threadDelay freq 16 | runBot config 17 | 18 | bot :: RBot () 19 | bot = handleMessages >> handleSubreddits 20 | -------------------------------------------------------------------------------- /src/Slantbot/Reddit/Config.hs: -------------------------------------------------------------------------------- 1 | module Slantbot.Reddit.Config where 2 | 3 | import Algolia.Query 4 | import Data.ByteString (ByteString) 5 | import Reddit 6 | 7 | data RedditConfig = RedditConfig 8 | { redditInfo :: !RedditInfo 9 | , redditFrequency :: !Int 10 | , redditOptions :: !RedditOptions 11 | } 12 | instance Show RedditConfig where 13 | show x = "RedditConfig {redditBaseInfo = " ++ show (redditInfo x) 14 | ++ ", redditFrequency = " ++ show (redditFrequency x) 15 | ++ ", redditOptions = }" 16 | 17 | data RedditInfo = RedditInfo 18 | { algoliaProfile :: !AlgoliaProfile 19 | , database :: !ByteString 20 | , maintainer :: !Username 21 | , username :: !Username 22 | } deriving (Show) 23 | -------------------------------------------------------------------------------- /src/Slantbot/Reddit/Messages.hs: -------------------------------------------------------------------------------- 1 | module Slantbot.Reddit.Messages (handleMessages) where 2 | 3 | import Control.Monad 4 | import Data.Monoid 5 | import Reddit 6 | import Reddit.Types.Message 7 | import Slantbot.Reddit.Monad 8 | 9 | handleMessages :: RBot () 10 | handleMessages = do 11 | captcha <- needsCaptcha 12 | unless captcha $ do 13 | Listing _ _ messages <- getUnread 14 | mapM_ handleMessage messages 15 | 16 | handleMessage :: Message -> RBot () 17 | handleMessage message = do 18 | case from message of 19 | Just (Username sender) -> 20 | case messageID message of 21 | PrivateMessage _ -> do 22 | maintainer <- maintainer' 23 | sendMessage maintainer mtopic (mbody sender) 24 | _ -> return () 25 | markRead message 26 | where 27 | mtopic = "fwd: " <> subject message 28 | mbody sender = "from /u/" <> sender <> "\n\n---\n" <> body message 29 | -------------------------------------------------------------------------------- /src/Slantbot/Reddit/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | 3 | module Slantbot.Reddit.Monad where 4 | 5 | import Algolia.Query 6 | import Control.Monad.Reader 7 | import Data.ByteString (ByteString) 8 | import Reddit.Types.Reddit 9 | import Reddit.Types.User 10 | import Slantbot.Reddit.Config 11 | 12 | type RBot a = RedditT (ReaderT RedditInfo IO) a 13 | 14 | ask' :: RBot RedditInfo 15 | ask' = lift ask 16 | 17 | algoliaProfile' :: RBot AlgoliaProfile 18 | algoliaProfile' = algoliaProfile <$> ask' 19 | 20 | database' :: RBot ByteString 21 | database' = database <$> ask' 22 | 23 | maintainer' :: RBot Username 24 | maintainer' = maintainer <$> ask' 25 | 26 | username' :: RBot Username 27 | username' = username <$> ask' 28 | -------------------------------------------------------------------------------- /src/Slantbot/Reddit/Subreddits.hs: -------------------------------------------------------------------------------- 1 | module Slantbot.Reddit.Subreddits (handleSubreddits) where 2 | 3 | import Control.Monad 4 | import Control.Monad.IO.Class 5 | import Control.Monad.Trans.Maybe 6 | import Data.Char 7 | import Data.Coerce 8 | import Data.Maybe 9 | import Data.Monoid 10 | import Data.Text (unpack) 11 | import Database.PostgreSQL.Simple 12 | import Reddit 13 | import Reddit.Types.Comment 14 | import Slantbot.Algolia 15 | import Slantbot.Reddit.Monad 16 | import Slantbot.Reddit.Subreddits.Permissions 17 | import Slantbot.Reddit.Subreddits.Responses 18 | 19 | handleSubreddits :: RBot () 20 | handleSubreddits = do 21 | self <- username' 22 | lastPID <- fromMaybe (CommentID "0") <$> getLastParentID self 23 | mapM_ (scanSub self lastPID) =<< getSubs' =<< database' 24 | where 25 | getSubs' db = liftIO $ do 26 | conn <- connectPostgreSQL db 27 | subs <- fmap R <$> getSubs conn 28 | close conn 29 | return subs 30 | 31 | getLastParentID :: Username -> RBot (Maybe CommentID) 32 | getLastParentID user = do 33 | comments <- getUserComments user 34 | case comments of 35 | (Listing _ _ cs) 36 | -> findM (fmap inReplyTo . getCommentInfo . commentID) cs 37 | _ -> return Nothing 38 | where 39 | findM f = runMaybeT . msum . map (MaybeT . f) 40 | 41 | scanSub :: Username -> CommentID -> SubredditName -> RBot () 42 | scanSub self lastPID sub = do 43 | Listing _ _ comments 44 | <- getNewComments' (Options Nothing (Just 100)) $ Just sub 45 | mapM_ (handleComment self lastPID) comments 46 | 47 | handleComment :: Username -> CommentID -> Comment -> RBot () 48 | handleComment self lastPID comment = do 49 | amParent <- checkParent 50 | unless (oldComment || amAuthor || amParent) 51 | $ case getQueryString self comment of 52 | Just q -> do 53 | haveReplied <- checkChildren 54 | unless haveReplied $ respondToQuery q comment 55 | _ -> return () 56 | where 57 | oldComment = lastPID >= commentID comment 58 | check c = author c == self 59 | amAuthor = check comment 60 | checkParent = case inReplyTo comment of 61 | Just parentID -> check <$> getCommentInfo parentID 62 | _ -> return False 63 | checkChildren = do 64 | children <- getMoreChildren (parentLink comment) [commentID comment] 65 | or <$> mapM resolveComment children 66 | resolveComment c' = case c' of 67 | Actual c -> return $ check c 68 | Reference _ cs -> any check <$> mapM getCommentInfo cs 69 | 70 | 71 | getQueryString :: Username -> Comment -> Maybe String 72 | getQueryString self = check . lines . unpack . body 73 | where 74 | check [] = Nothing 75 | check (x:_) = case words x of 76 | ('@':u):q | fmap toLower u == fmap toLower (unpack . coerce $ self) 77 | -> Just $ unwords q 78 | _ -> Nothing 79 | 80 | respondToQuery :: String -> Comment -> RBot () 81 | respondToQuery q (Comment {commentID = cid, subreddit = (R sub)}) = do 82 | profile <- algoliaProfile' 83 | question <- liftIO $ questionSearch profile q 84 | let utm = "?utm_source=reddit&utm_medium=bot&utm_campaign=" <> sub 85 | reply cid $ response question utm 86 | return () 87 | -------------------------------------------------------------------------------- /src/Slantbot/Reddit/Subreddits/Permissions.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Slantbot.Reddit.Subreddits.Permissions where 5 | 6 | import Control.Monad 7 | import Data.Char 8 | import Data.Maybe 9 | import Data.Text (Text) 10 | import Database.PostgreSQL.Simple hiding (Automatic) 11 | 12 | data SP = Forbidden | Invoked | Automatic 13 | deriving (Show, Eq) 14 | 15 | getSubs :: Connection -> IO [Text] 16 | getSubs db = do 17 | xs :: [Only (Maybe Text)] 18 | <- query_ db "SELECT (subreddit) FROM subreddits" 19 | return . catMaybes . fmap fromOnly $ xs 20 | 21 | -- These are currently for GHCI use. But, maybe one day... 22 | setSP :: Connection -> String -> SP -> IO () 23 | setSP db sub' sp = do 24 | _ <- execute db 25 | "DELETE FROM subreddits WHERE subreddit=?" 26 | (Only sub) 27 | when (sp /= Forbidden) put 28 | where 29 | sub = toLower <$> sub' 30 | put = do 31 | _ <- execute db 32 | "INSERT INTO subreddits VALUES (?,?)" 33 | (sub, sp == Automatic) 34 | return () 35 | 36 | getSP :: Connection -> String -> IO SP 37 | getSP db sub' = do 38 | xs :: [(Text, Maybe Bool)] <- query db 39 | "select * from subreddits where subreddit=?" 40 | (Only sub) 41 | return $ go xs 42 | where sub = fmap toLower sub' 43 | go [] = Forbidden 44 | go ((_,p):_) | p == Just True = Automatic 45 | | otherwise = Invoked 46 | -------------------------------------------------------------------------------- /src/Slantbot/Reddit/Subreddits/Responses.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Slantbot.Reddit.Subreddits.Responses where 4 | 5 | import Data.Monoid 6 | import Data.Text (Text, pack, unpack, strip) 7 | import qualified Data.Text as T 8 | import Slantbot.Algolia 9 | 10 | response :: Maybe Question -> Text -> Text 11 | response question utm = responseBody question utm <> responseFooter 12 | 13 | responseBody :: Maybe Question -> Text -> Text 14 | responseBody q utm = case q of 15 | Just q' -> responseWith q' utm 16 | _ -> responseNoResult utm 17 | 18 | responseFooter :: Text 19 | responseFooter 20 | = "\n\n---\n\ 21 | \^(I am a bot! For safety, replies to this comment will be ignored. \ 22 | \Private messages are forwarded to a human.)" 23 | 24 | responseNoResult :: Text -> Text 25 | responseNoResult utm 26 | = "Sorry, I couldn't find anything for that query. I've really dropped the \ 27 | \ball on this one... if you'll excuse me, I feel the need to go sit \ 28 | \quietly in a corner." 29 | {- SPAM PANIC 30 | \n\n\ 31 | \If you want, though, you could try asking this question directly on \ 32 | \[Slant](http://www.slant.co/"<>utm<>"), where I get my data. It might \ 33 | \save me some embarrassment the next time someone asks about this!" 34 | -} 35 | 36 | responseWith :: Question -> Text -> Text 37 | responseWith q utm 38 | {- SPAM PANIC 39 | = "Hi there! It looks like you're asking: \n" 40 | <> "[*" <> (strip $ questionTitle q) <> "*](" <> qURL <> ")\n\n" 41 | <> intro <> (T.concat $ take 3 options) <> "\n\n" <> outro 42 | -} 43 | | ocount == 0 44 | = responseNoResult utm 45 | | otherwise 46 | = "Hi there! It looks like you're asking: \n" 47 | <> "*" <> (strip $ questionTitle q) <> "*\n\n" 48 | <> intro <> (T.concat $ take 5 options) 49 | where 50 | options = format <$> questionOptions q 51 | ocount = length options 52 | {- SPAM PANIC 53 | url = "http://www.slant.co/topics/" <> pack (show $ questionID q) 54 | qURL = url <> utm 55 | format o = "\n\n" <> prefix (optionID o) <> title o 56 | prefix n = "- [(s)](" <> url <> "/viewpoints/" <> pack (show n) 57 | <> utm <> ") / " 58 | -} 59 | format o = "\n\n- " <> title o 60 | optGet o = strip $ optionGet o 61 | title o = case unpack $ optGet o of 62 | 'h':'t':'t':'p':_ 63 | -> "[" <> t <> "](" <> optGet o <> ")" 64 | _ -> t 65 | where 66 | t = "**" <> (strip $ optionTitle o) <> "**" 67 | intro | ocount == 0 68 | = "Whoops... I have no recommended options. \ 69 | \This message should never appear, so I've also got a bug!" 70 | | ocount == 1 = "I have one recommended option:" 71 | | otherwise = "I have these recommended options:" 72 | {- SPAM PANIC 73 | intro | ocount == 0 = "" 74 | | ocount == 1 = "I have one recommended option:" 75 | | ocount == 2 = "I have two recommended options:" 76 | | ocount == 3 = "I have three recommended options:" 77 | | otherwise = "My most recommended options are:" 78 | note | ocount == 0 = "" 79 | | otherwise 80 | = "\n\n*(s) goes to the option's pros and cons on Slant.*" 81 | outro | ocount == 0 = oEmpty 82 | | ocount < 4 = oShort 83 | | ocount == 4 = oPlus1 84 | | otherwise = oFull 85 | oEmpty 86 | = "Unfortunately, although that question has been asked, no options \ 87 | \have been suggested yet. If anyone has a recommendation, adding it \ 88 | \to Slant via the question link above would help avoid this tragic \ 89 | \outcome in the future." 90 | oSingle | ocount == 1 = "Kind of looks lonely there, all by itself... i" 91 | | otherwise = "I" 92 | oShort 93 | = "At the moment, that's all I've got. " <> oSingle <> "f anyone has \ 94 | \another recommendation, adding it to Slant via the question link \ 95 | \above would help improve my answer next time this is asked." 96 | oPlus1 97 | = "There's one more option recommended for this question, but I'm \ 98 | \programmed to show a maximum of three. Hey, rules are rules! You \ 99 | \can click the question link above to see it, or add your own." 100 | oFull 101 | = "In addition to these, another " <> (pack . show $ ocount - 3) <> 102 | " options have been suggested. To see them too, or to make your own \ 103 | \suggestion, follow the question link above." 104 | -} 105 | --------------------------------------------------------------------------------