diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Aaron Ash + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Main where + +import Control.Applicative +import Control.Concurrent (threadDelay) +import Control.Lens +import Control.Monad (when,forever) +import Control.Monad.Catch (try) +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Reader (ask) +import Control.Monad.State (modify) +import Control.Monad.Trans.Resource +import Data.Acid +import Data.SafeCopy +import Data.String.Utils +import Data.Typeable +import Language.Haskell.Interpreter (runInterpreter) +import Mueval.ArgsParse +import Mueval.Interpreter +import Web.Twitter.Conduit +import Web.Twitter.Types.Lens +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import Tokens +import Common + +-- Strip off the first world (which is assumed to be the screenname of the +-- bot). +getHaskellExpression :: T.Text -> T.Text +getHaskellExpression t = + case T.breakOn " " $ T.strip t of + (a, "") -> a + (_, rest) -> T.strip rest + +isHaskellPost :: T.Text -> Status -> Bool +isHaskellPost userName status = + (T.isPrefixOf userName $ status ^. statusText) && + (status ^. statusUser ^. userScreenName) /= botScreenName + +evalExpr :: String -> IO String +evalExpr e = + case getOptions ["--expression", e] of + Left t@(b, e) -> return $ show t + Right opts -> do + r <- runInterpreter (interpreter opts) + case r of + Left err -> return $ show err + Right (e,et,val) -> do (out, b) <- getResult val + return out + +getResult :: (Functor m, MonadIO m) => String -> m (String, Bool) +getResult str = render 1024 str + +statusToText :: Status -> T.Text +statusToText status = T.concat [ T.pack . show $ status ^. statusId + , ": " + , status ^. statusUser . userScreenName + , ": " + , status ^. statusText + ] + +evalExpression :: MonadIO m => Status -> m String +evalExpression status = do + r <- liftIO $ evalExpr $ decodeHtml $ T.unpack $ getHaskellExpression $ status ^. statusText + return $ take 140 r + +{-TODO: Make this more comprehensive-} +decodeHtml :: String -> String +decodeHtml s = + replace "<" "<" $ + replace ">" ">" $ + replace "&" "&" $ + replace """ "\"" $ + replace "'" "'" $ s + +-- res <- call $ update "Hello World" +reply :: Integer -> T.Text -> APIRequest StatusesUpdate Status +reply i s = + Web.Twitter.Conduit.update s & inReplyToStatusId ?~ i + +postreply :: (MonadResource m, MonadLogger m) => Status -> Integer -> String -> TW m Status +postreply status i res = call (reply i $ (T.take 140 $ + T.concat ["@", + status ^. statusUser ^. userScreenName, + " ", + T.pack res])) + + +{-Acid State database to keep track of replies-} +data TweetId = TweetId { tweetId :: Integer } + deriving (Eq, Show, Typeable) +data LambdaTwitDb = LambdaTwitDb { allReplyIds :: [TweetId] } + deriving (Typeable) + +allReplies :: Query LambdaTwitDb [TweetId] +allReplies = allReplyIds <$> ask + +addReply :: TweetId -> Update LambdaTwitDb () +addReply tweetId = modify go + where go (LambdaTwitDb db) = LambdaTwitDb $ tweetId : db + +{-The Acid State magic-} +deriveSafeCopy 0 'base ''TweetId +deriveSafeCopy 0 'base ''LambdaTwitDb +makeAcidic ''LambdaTwitDb ['allReplies, 'addReply] + +conduitmain :: IO () +conduitmain = do + state <- openLocalState (LambdaTwitDb []) + forever $ do + {-TODO: Use Data.Configurator to read in the oauth keys without needing a recompile: + - http://hackage.haskell.org/package/configurator-} + runNoLoggingT . runTwitterFromEnv $ do + sourceWithMaxId mentionsTimeline + C.$= CL.isolate 100 + C.$$ CL.mapM_ $ \status -> do + replies <- liftIO $ query state AllReplies + if ((TweetId (status ^. statusId)) `elem` replies) + then do + liftIO $ putStrLn "Already replied to:" + liftIO $ T.putStrLn $ statusToText status + liftIO $ threadDelay $ 60 * 1000000 + else do + when (isHaskellPost botScreenName status) $ do + liftIO $ T.putStrLn $ statusToText status + res <- evalExpression status + liftIO $ putStrLn res + postres <- try $ postreply status (status ^. statusId) res + case postres of + Left (FromJSONError e) -> liftIO $ print e + Left (TwitterErrorResponse s resH errs) -> + liftIO $ print errs + Left (TwitterStatusError s resH val) -> + liftIO $ print val + Right status -> liftIO $ print $ statusToText status + liftIO $ Data.Acid.update state (AddReply $ TweetId (status ^. statusId)) + -- AA TODO: Better rate limiting, this probably blocks every tweet. + -- We should only wait for 60 seconds after each mentionsTimeline grab + liftIO $ threadDelay $ 60 * 1000000 + +main :: IO () +main = conduitmain + +{-TODO: Import lens:-} +{-https://twitter.com/relrod6/status/516785803100688384-} + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lambdatwit.cabal b/lambdatwit.cabal new file mode 100644 --- /dev/null +++ b/lambdatwit.cabal @@ -0,0 +1,74 @@ +-- Initial lambdatwit.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: lambdatwit +version: 0.1.0.0 +synopsis: Lambdabot running as a twitter bot. Similar to the @fsibot f# bot. +description: A twitter bot using mueval to evaluate haskell tweets. + Further info: +license: MIT +license-file: LICENSE +author: Aaron Ash +maintainer: aaron.ash@gmail.com +homepage: http://github.com/ashyisme/lambdatwit +bug-reports: https://github.com/ashyisme/lambdatwit/issues +-- copyright: +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/ashyisme/lambdatwit.git + +executable lambdatwit + main-is: Main.hs + build-depends: base + , acid-state + , authenticate-oauth + , bytestring + , case-insensitive + , conduit + , containers + , data-default + , exceptions + , hint + , http-conduit + , lens + , MissingH + , monad-control + , monad-logger + , mtl + , mueval + , network-uri + , resourcet + , safecopy + , text + , transformers == 0.3.0.0 + , transformers-base + , twitter-conduit + , twitter-types + , utf8-string + + -- hs-source-dirs: + default-language: Haskell2010 + +executable oauth_pin + main-is: oauth_pin.hs + + build-depends: + base >= 4.5 && < 5 + , containers + , transformers-base + , transformers + , monad-control + , bytestring + , text + , resourcet + , conduit + , http-types + , http-conduit + , authenticate-oauth + , twitter-conduit + default-language: Haskell2010 diff --git a/oauth_pin.hs b/oauth_pin.hs new file mode 100644 --- /dev/null +++ b/oauth_pin.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +-- Example: +-- $ export OAUTH_CONSUMER_KEY="your consumer key" +-- $ export OAUTH_CONSUMER_SECRET="your consumer secret" +-- $ runhaskell oauth_pin.hs + +module Main where + +import Web.Twitter.Conduit hiding (lookup) +import Web.Authenticate.OAuth as OA +import Network.HTTP.Conduit +import qualified Data.Conduit as C +import qualified Data.ByteString.Char8 as S8 +import Data.Maybe +import Data.Monoid +import Control.Monad.Trans.Control +import Control.Monad.Trans.Resource +import Control.Monad.IO.Class +import System.Environment +import System.IO (hFlush, stdout) + +getTokens :: IO OAuth +getTokens = do + consumerKey <- getEnv "OAUTH_CONSUMER_KEY" + consumerSecret <- getEnv "OAUTH_CONSUMER_SECRET" + return $ + twitterOAuth + { oauthConsumerKey = S8.pack consumerKey + , oauthConsumerSecret = S8.pack consumerSecret + , oauthCallback = Just "oob" + } + +authorize :: (MonadBaseControl IO m, MonadResource m) + => OAuth -- ^ OAuth Consumer key and secret + -> Manager + -> m Credential +authorize oauth mgr = do + cred <- OA.getTemporaryCredential oauth mgr + let url = OA.authorizeUrl oauth cred + pin <- getPIN url + OA.getAccessToken oauth (OA.insert "oauth_verifier" pin cred) mgr + where + getPIN url = liftIO $ do + putStrLn $ "browse URL: " ++ url + putStr "> what was the PIN twitter provided you with? " + hFlush stdout + S8.getLine + +main :: IO () +main = do + tokens <- getTokens + Credential cred <- liftIO $ withManager $ authorize tokens + print cred + + S8.putStrLn . S8.intercalate "\n" $ + [ "export OAUTH_CONSUMER_KEY=\"" <> oauthConsumerKey tokens <> "\"" + , "export OAUTH_CONSUMER_SECRET=\"" <> oauthConsumerSecret tokens <> "\"" + , "export OAUTH_ACCESS_TOKEN=\"" <> fromMaybe "" (lookup "oauth_token" cred) <> "\"" + , "export OAUTH_ACCESS_SECRET=\"" <> fromMaybe "" (lookup "oauth_token_secret" cred) <> "\"" + ]