module Web.Twitter.Monad
( TM
, TMEnv(..)
, withEnv
, withUser
, withCount
, withPage
, withPageCount
, withAuth
, withBase
, getEnv
, getUser
, getCount
, getPage
, getPageCount
, getBase
, getPostFlag
, runTwitter
, runTM
, liftIO
, api_base
, user_base_url
, top_base_url
, acc_base_url
, Result(..)
, decodeStrict
, mbArg
, arg
, restCall
, postCall
, readResult
, postMethod
) where
import Text.JSON
import Text.JSON.Types
import Control.Monad
import Data.List
import Web.Codec.URLEncoder
import Web.Twitter.Fetch
api_base :: URLString
api_base = "http://www.twitter.com/statuses/"
top_base_url :: URLString
top_base_url = "http://www.twitter.com/"
user_base_url :: URLString
user_base_url = "http://www.twitter.com/users/"
acc_base_url :: URLString
acc_base_url = "http://www.twitter.com/account/"
mbArg :: String -> Maybe String -> [(String,String)] -> [(String,String)]
mbArg _ Nothing xs = xs
mbArg f (Just x) xs = (f,x):xs
arg :: String -> String -> [(String,String)] -> [(String,String)]
arg f x xs = (f,x):xs
restCall :: String -> [(String,String)] -> TM String
restCall u args = do
mbc <- getCount
mbp <- getPage
let q = maybe id (\ x -> (("count="++show x):)) mbc $
maybe id (\ x -> (("page="++show x):)) mbp $
(map (\ (x,y) -> x ++ '=':encodeString y) args)
b <- getBase
let url = b++ u ++ case q of { [] -> "" ; xs -> '?':intercalate "&" xs}
isA <- getUser
isP <- getPostFlag
case isA of
Nothing -> liftIO (readContentsURL url)
Just au
| isP -> liftIO (postContentsURL (Just au) url [] [] "" >>= \ (a,b,c) -> return c)
| otherwise -> liftIO (readUserContentsURL (Just au) True False url [] >>= \ (a,b) -> return b)
postCall :: String -> [(String,String)] -> String -> [(String,String)] -> TM ([Cookie],[(String,String)], String)
postCall u hs bod args = do
mbc <- getCount
mbp <- getPage
let q = maybe id (\ x -> (("count="++show x):)) mbc $
maybe id (\ x -> (("page="++show x):)) mbp $
(map (\ (x,y) -> x ++ '=':encodeString y) args)
b <- getBase
let url = b++ u ++ case q of { [] -> u ; xs -> '?':u ++ intercalate "&" xs}
isA <- getUser
isP <- getPostFlag
liftIO (postContentsURL isA url hs [] bod)
readResult :: JSON a => String -> String -> TM a
readResult loc s =
case decode s of
Ok e -> return e
Error e ->
case s of
('"':xs) ->
readResult loc (init xs)
_ -> liftIO $ ioError $ userError (loc ++ ':':' ':e)
data TMEnv
= TMEnv
{ tmUser :: Maybe AuthUser
, tmBase :: URLString
, tmCount :: Maybe Int
, tmPage :: Maybe Int
, tmPost :: Bool
}
nullEnv :: TMEnv
nullEnv = TMEnv
{ tmUser = Nothing
, tmBase = api_base
, tmCount = Nothing
, tmPage = Nothing
, tmPost = False
}
newtype TM a = TM {unTM :: TMEnv -> IO a}
instance Monad TM where
return x = TM $ \ _ -> return x
m >>= k = TM $ \ env -> do
v <- unTM m env
unTM (k v) env
withEnv :: (TMEnv -> TMEnv) -> TM a -> TM a
withEnv fenv k = TM $ \ env -> (unTM k) (fenv env)
withUser :: AuthUser -> TM a -> TM a
withUser u k = withEnv (\ e -> e{tmUser=Just u}) k
withCount :: Int -> TM a -> TM a
withCount c k = withEnv (\e -> e{tmCount=Just c}) k
withPage :: Int -> TM a -> TM a
withPage c k = withEnv (\e -> e{tmPage=Just c}) k
withBase :: URLString -> TM a -> TM a
withBase u t = withEnv (\ e -> e{tmBase=u}) t
withPageCount :: Maybe Int -> Maybe Int -> TM a -> TM a
withPageCount mbP mbC k = withEnv (\e -> e{tmPage=mbP,tmCount=mbC}) k
withAuth :: Bool -> TM a -> TM a
withAuth False tm = withEnv (\e -> e{tmUser=Nothing}) tm
withAuth _ tm = tm
postMethod :: TM a -> TM a
postMethod (TM x) = TM $ \ env -> x env{tmPost=True}
getPostFlag :: TM Bool
getPostFlag = getEnv >>= return.tmPost
getUser :: TM (Maybe AuthUser)
getUser = TM $ \ env -> return (tmUser env)
getEnv :: TM TMEnv
getEnv = TM $ \ env -> return env
getCount :: TM (Maybe Int)
getCount = TM $ \ env -> return (tmCount env)
getPage :: TM (Maybe Int)
getPage = TM $ \ env -> return (tmPage env)
getPageCount :: TM (Maybe Int, Maybe Int)
getPageCount = TM $ \ env -> return (tmCount env, tmPage env)
getBase :: TM URLString
getBase = TM $ \ env -> return (tmBase env)
liftIO :: IO a -> TM a
liftIO a = TM $ \ _ -> a
runTwitter :: Maybe AuthUser -> URLString -> TM a -> IO a
runTwitter mbu b dm = (unTM dm) nullEnv{tmUser=mbu,tmBase=b}
runTM :: AuthUser -> TM a -> IO a
runTM user a = runTwitter (Just user) api_base a