-----------------------------------------------------------------------------
-- |
-- Module      :  TwitterReplyBot
-- Copyright   :  (c) Katsutoshi Itoh 2009
-- License     :  BSD3
-- 
-- Maintainer  :  cut-sea@timedia.co.jp
-- Stability   :  experimental
-- Portability :  posix like system only
--
-- a simple library to write Reply Bot for Twitter.
--
-----------------------------------------------------------------------------
module TwitterReplyBot
    (
     -- * TwitterReplyBot
     Account(..)
    ,Program
    ,loop
     
     -- * Examples
     -- sample application make to reply comments for each comments.

     -- ** Echo reply bot
     -- $example1
     ) where

import Data.Maybe
import Data.Ratio
import Network.HTTP
import Network.URI
import qualified Codec.Binary.Base64.String as Base64
import qualified Codec.Binary.UTF8.String as C
import qualified Text.JSON as J
import Text.JSON.Types
import System.Posix.Unistd

-- |Twitter Account
data Account = Account { tId::String    -- ^ user name
                       , tPass::String  -- ^ password
                       } deriving Show
-- |generate reply text from comment text
type Program = String -> String
-- |twitter request
type TwReq = Account -> Request
-- |make of name and comment text
-- first string is screen_name,second is text
type Comment = (String,String)
-- |twitter base url
twitterURIbase :: String
twitterURIbase = "http://twitter.com/"

toUri :: String -> URI
toUri url = fromJust $ parseURI url

authHeader :: Account -> Header
authHeader acc
 = Header HdrAuthorization basic
   where
     basic = "Basic " ++ Base64.encode str
     str = (tId acc ++ ":" ++ tPass acc)
-- |twitter get/post request
twGetReq,twPostReq :: String -> Account -> Request
(twGetReq,twPostReq) = (gen GET, gen POST)
  where
    toUri' path = toUri $ twitterURIbase ++ path
    gen meth path acc
        = Request (toUri' path) meth [authHeader acc] ""
-- |encoding key and value\'s list
-- to query parameter string
encodeQPs :: [(String, String)] -> String
encodeQPs qps = urlEncodeVars $ map toUtf8 qps
  where
    toUtf8 (k,v)
       = (C.encodeString k,C.encodeString v)
-- |twitter API : request of verify_credentials
verify_credentials :: Account -> Request
verify_credentials acc = twGetReq path acc
  where
    path = "account/verify_credentials.json"
-- |twitter API : request of replies
replies :: Integer -> TwReq
replies 0  acc
 = twGetReq "statuses/replies.json" acc
replies id acc
 = twGetReq ("statuses/replies.json?" ++ s) acc
    where s = encodeQPs [("since_id", show id)]
-- |twitter API : request of update
update :: String -> Account -> Request
update msg acc
 = twPostReq ("statuses/update.json?"++m) acc
    where m = encodeQPs [("status", msg)]
-- |action to communicate twitter server
api :: Account -> TwReq -> IO Response
api acc req
 = do Right res <- simpleHTTP $ req acc
      return res
{- |
bot\'s main loop

* first argument type Integer is since_id
  for replies\'s option parameter.

* second argument type Account is bot\'s
  twitter account.

* last argument type Program is application
  embedded on bot.
-}
loop :: Integer -> Account -> Program
     -> IO ()
loop id acc prog
 = do { res <- api acc $ replies id
      ; let id' = getLastId id res
            cs = getComments res
      ; mapM_ (api acc . mkReply prog) cs
      ; sleep 60
      ; loop id' acc prog
      }
-- |make reply by apply program to comment
mkReply :: Program -> Comment -> TwReq
mkReply prog (name, text)
 = update $ "@"++name++" "++(prog text)
-- |get comments from HTTP response
getComments :: Response -> [Comment]
getComments res
 = map (\c -> (getScreenName c,getText c))
   $ getArray $ getJSVal res
-- |calculate last status_id from HTTP response
getLastId :: Integer -> Response -> Integer
getLastId id res
 = maximum $
   id:(map getId $ getArray $ getJSVal res)

-- |get screen_name from comment JSON value
getScreenName :: J.JSValue -> String
getScreenName x
 = getString $ fieldOf "screen_name"
             $ fieldOf "user" x
-- |get text from comment JSON value
getText :: J.JSValue -> String
getText x = getString $ fieldOf "text" x
-- |get status_id from comment JSON value
getId :: J.JSValue -> Integer
getId x = numerator
        $ getRational $ fieldOf "id" x
-- |get JSON value from HTTP response
getJSVal :: Response -> J.JSValue
getJSVal r = case J.decode $ rspBody r of
               J.Ok x    -> x
               J.Error _ -> undefined
-- |get list of JSON value from JSON value
getArray :: J.JSValue -> [J.JSValue]
getArray (J.JSArray x) = x
getArray _             = undefined
-- |get rational from JSON value
getRational :: J.JSValue -> Rational
getRational (J.JSRational _ x) = x
getRational _                  = undefined
-- |get string from JSON value
getString :: J.JSValue -> String
getString (J.JSString x) = J.fromJSString x
getString _              = undefined
-- |field accessor
fieldOf :: String -> J.JSValue -> J.JSValue
fieldOf name (J.JSObject x)
 = fromJust $ get_field x name

{- $example1

This sample application is Echo twitter bot.
The bot replies a same comment for user.

>     module Main where
>     
>     import TwitterReplyBot
>     
>     habot :: Account
>     habot = Account "habot" "haskellworld"
>     
>     prog :: Program
>     prog = id
>     
>     main :: IO ()
>     main = loop 0 habot prog

-}