apoca.hs

{-# LANGUAGE PackageImports, StandaloneDeriving #-}
import Text.HTML.TagSoup
import Data.Maybe (fromJust)
import Data.Monoid
import Control.Monad
import Control.Applicative
import "mtl" Control.Monad.Trans
import Network.Curl
import Codec.Text.IConv
import Codec.Binary.UTF8.String (decodeString)
import Network.OAuth.Consumer
import Network.OAuth.Http.Request
import Network.OAuth.Http.Response
import Network.OAuth.Http.HttpClient
import Network.OAuth.Http.PercentEncoding
import Network.OAuth.Http.CurlHttpClient
import System.Directory

import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Char8 as C
import qualified Data.Binary as Binary

deriving instance Show Application
deriving instance Show Token

newsUrl = "http://kodu.ut.ee/~roman_l/global.php" :: String

reqUrl = fromJust . parseURL $ "https://api.twitter.com/oauth/request_token"
accUrl = fromJust . parseURL $ "https://api.twitter.com/oauth/access_token"

tweetUrl = fromJust . parseURL $ "https://api.twitter.com/1.1/statuses/update.json"

authUrl = ("https://api.twitter.com/oauth/authorize?oauth_token=" ++)
            . findWithDefault ("oauth_token","") . oauthParams

consumerKey    = YOURKEYHERE
consumerSecret = YOURSECRETHERE

data Consumer = Consumer
    { key :: String
    , secret :: String }
    deriving (Show, Eq)

authenticate :: Consumer -> IO Token
authenticate consumer =
    let app' = app consumer in 
    runOAuthM (fromApplication app') $ do
    liftIO $ putStrLn "Step 1"

    -- todo: add oauth_callback here
    s1 <- signRq2 HMACSHA1 Nothing reqUrl
    liftIO $ putStrLn (show s1)
    oauthRequest CurlClient s1
    -- should store the token
    -- oauth_token, oauth_token_secret

    liftIO $ putStrLn "Step 2"
    cliAskAuthorization authUrl
    -- change this to redirect to
    -- e.g. https://api.twitter.com/oauth/authenticate?oauth_token=NPcudxy0yU5T3tBzho7iCotZ3cnetKwcTIRlX0iwRl0
    --
    liftIO $ putStrLn "Getting Access Token"

    accessToken <- (signRq2 HMACSHA1 Nothing accUrl >>= oauthRequest CurlClient)
    liftIO $ putStrLn $ show (oauthParams accessToken)
    return accessToken

app consumer = Application (key consumer) (secret consumer) OOB

tweet :: Consumer -> Token -> String -> IO ()
tweet consumer token message = runOAuthM token $ do
    ignite $ Application (key consumer) (secret consumer) OOB
    putToken token
    -- I can't figure out how to put the status in the POST body, but putting
    -- it in the query string works.
    let body = "status=" ++ encode message
        request = tweetUrl { method = POST
                           , qString = fromList [("status", message)]
                           }
    req <- signRq token HMACSHA1 Nothing request
    resp <- serviceRequest CurlClient req
    liftIO $ when (status resp /= 200) $
         print resp

readToken :: IO Token
readToken = Binary.decode <$> B.readFile "mytoken"

writeToken:: Token -> IO ()
writeToken token = void $ B.writeFile "mytoken" (Binary.encode token)

firstRun :: Consumer -> IO ()
firstRun consumer = putStrLn "Getting token" >> authenticate consumer >>= writeToken

data ParseState = Init | CopyNext | Done (Tag [Char])

getText = do
    (_, resp) <- curlGetString_ newsUrl []
    let body = convert "CP1251" "UTF-8" resp :: B.ByteString
    let tags = parseTags $ C.unpack $ mconcat $ B.toChunks body
    let (Done (TagText text)) = foldl (\s t -> case s of
                            Init -> case t of 
                                        (TagOpen "h2" _) -> CopyNext
                                        _ -> Init
                            CopyNext -> Done t
                            _ -> s) Init tags
    return $ decodeString $ tail text

getTweet = head <$> map (mfilter ((<= 140).length)) $ repeat getText

main :: IO ()
main = do
    let consumer = Consumer consumerKey consumerSecret
    token <- (doesFileExist "mytoken" >>= (\b -> case b of 
                True -> readToken
                False -> firstRun consumer >> readToken))
    text <- getTweet
    putStrLn text
    tweet consumer token text
    putStrLn "ok"