module FriendFeed.Monad where
import Data.List ( intercalate )
import Util.Fetch
import Util.Codec.URLEncoder
import Data.Maybe
import Control.Exception as CE
import Data.Typeable
import Text.JSON
import Text.JSON.Types
import Text.JSON.String
newtype FFm a = FFm (FFmEnv -> IO a)
data FFmEnv
= FFmEnv
{ ffm_auth_user :: AuthUser
, ffm_page_size :: Maybe Int
, ffm_entry_start :: Maybe Int
, ffm_services_filter :: [String]
, ffm_is_post :: Bool
, ffm_base :: URLString
}
nullFFmEnv :: AuthUser -> FFmEnv
nullFFmEnv au
= FFmEnv
{ ffm_auth_user = au
, ffm_page_size = Nothing
, ffm_entry_start = Nothing
, ffm_services_filter = []
, ffm_is_post = False
, ffm_base = api_base
}
runFF :: String -> String -> FFm a -> IO a
runFF a b (FFm x) = x (nullFFmEnv (AuthUser a b))
withUser :: String -> String -> FFm a -> FFm a
withUser nm rkey x
= withEnv (\env -> env{ffm_auth_user=AuthUser{authUserName=nm,authUserKey=rkey}})
x
forService :: String -> FFm a -> FFm a
forService s = withEnv (\ env -> env{ffm_services_filter=[s]})
startIndex :: Int -> FFm a -> FFm a
startIndex p = withEnv (\ env -> env{ffm_entry_start=Just p})
withPageSize :: Int -> FFm a -> FFm a
withPageSize p = withEnv (\ env -> env{ffm_page_size=Just p})
withBase :: URLString -> FFm a -> FFm a
withBase b = withEnv (\ env -> env{ffm_base=b})
withEnv :: (FFmEnv -> FFmEnv) -> FFm a -> FFm a
withEnv f (FFm x) = FFm (\ env -> x (f env))
postMethod :: FFm a -> FFm a
postMethod a = withEnv (\ env -> env{ffm_is_post=True}) a
authCall :: FFm a -> FFm a
authCall x = x
data AuthUser
= AuthUser
{ authUserName :: String
, authUserKey :: String
}
instance Monad FFm where
return x = FFm (\ _ -> return x)
(FFm x) >>= k = FFm $ \ env -> do
v <- x env
case k v of
FFm y -> y env
liftIO :: IO a -> FFm a
liftIO act = FFm (\ _ -> act)
ffeedCall_ :: [String] -> [(String,String)] -> FFm ()
ffeedCall_ m args = (ffeedCall m args) >> return ()
checkResponse :: String -> ErrM String
checkResponse s = Right s
type ErrM a = Either FFeedErr a
ffeedTranslateSub :: JSON a => String -> FFm String -> FFm a
ffeedTranslateSub l a = do
vs <- a
case runGetJSON readJSObject vs of
Right (JSObject (JSONObject os)) ->
case lookup l os of
Just x -> dec vs x
_ -> liftIO (throwIO (toException FFeedErr{ffErrorCode="translate-error-field-missing-"++l, ffErrorLoc = (Just l), ffErrorSource = vs}))
_ -> liftIO (throwIO (toException FFeedErr{ffErrorCode="translate-error-field-missing-"++l, ffErrorLoc = (Just l), ffErrorSource = vs}))
where
dec vs x =
case readJSON x of
Error e -> liftIO (throwIO (toException FFeedErr{ffErrorCode="translate-error-"++l, ffErrorLoc = (Just e), ffErrorSource = vs }))
Ok s -> return s
ffeedTranslateLs :: JSON a => String -> FFm String -> FFm [a]
ffeedTranslateLs l a = do
vs <- a
case runGetJSON readJSObject vs of
Right (JSObject (JSONObject os)) ->
case lookup l os of
Just (JSArray xs) -> mapM (dec vs) xs
Just x -> dec vs x >>= \ v -> return [v]
Nothing -> return []
_ -> return []
where
dec vs x =
case readJSON x of
Error e -> liftIO (throwIO (toException FFeedErr{ffErrorCode="translate-error-"++l, ffErrorLoc = (Just e), ffErrorSource = vs }))
Ok s -> return s
ffeedTranslate :: JSON a => FFm String -> FFm a
ffeedTranslate a = do
x <- a
case decodeStrict x of
Error e -> liftIO (throwIO (toException FFeedErr{ffErrorCode="translate-error", ffErrorLoc = (Just e), ffErrorSource = x}))
Ok s -> return s
onSuccess :: FFm () -> FFm Bool
onSuccess (FFm x) = FFm (\ env -> do
v <- CE.try (x env)
case v of
Left SomeException{} -> return False
_ -> return True)
ffeedCall :: [String] -> [(String,String)] -> FFm String
ffeedCall ms args = FFm $ \ env -> do
let
service = intercalate "," $ ffm_services_filter env
start = ffm_entry_start env
num = ffm_page_size env
usr = ffm_auth_user env
meth = intercalate "/" ms
as = map (\ (x,y) -> encodeString x ++ '=':encodeString y) args
wArgs [] = ""
wArgs xs = '?':intercalate "&" xs
base = ffm_base env
url = base ++ meth ++ (if ffm_is_post env then "" else query)
query = (wArgs $
mbArg "num" (fmap show num) $
mbArg "start" (fmap show start) $
lsArg "service" service as)
ausr = User{userName=authUserName usr,userPass=authUserKey usr}
body = (crnl++crnl++tail query)
cs = [ ("Content-Type", "application/x-www-form-urlencoded")
, ("Content-Length", show (length body))
]
crnl = "\r\n"
rMeth
| ffm_is_post env = \ x -> postContentsURL (Just ausr) x cs body
| otherwise = readUserContentsURL ausr
rMeth url
mbArg :: String -> Maybe String -> [String] -> [String]
mbArg _ Nothing xs = xs
mbArg x (Just y) xs = (x++'=':encodeString y):xs
mbArg2 :: String -> Maybe String -> [(String,String)] -> [(String,String)]
mbArg2 _ Nothing xs = xs
mbArg2 x (Just y) xs = (x,y):xs
lsArg :: String -> String -> [String] -> [String]
lsArg _ [] xs = xs
lsArg x ys xs = (x++'=':encodeString ys):xs
api_base :: String
api_base = "http://friendfeed.com/api/"
ffeed_base :: String
ffeed_base = "http://friendfeed.com/"
data FFeedErr
= FFeedErr
{ ffErrorCode :: String
, ffErrorLoc :: Maybe String
, ffErrorSource :: String
} deriving Typeable
ffeedError :: FFeedErr
ffeedError
= FFeedErr { ffErrorCode = ""
, ffErrorLoc = Nothing
, ffErrorSource = ""
}
data SomeFFeedException = forall e . Exception e => SomeFFeedException e
deriving Typeable
instance Show SomeFFeedException where
show (SomeFFeedException e) = show e
instance Exception SomeFFeedException
ffeedToException :: Exception e => e -> SomeException
ffeedToException = toException . SomeFFeedException
ffeedFromException :: Exception e => SomeException -> Maybe e
ffeedFromException x = do
SomeFFeedException a <- fromException x
cast a
instance Exception FFeedErr where
toException = ffeedToException
fromException = ffeedFromException
handleFFeed :: (FFeedErr -> FFm a) -> FFm a -> FFm a
handleFFeed h e = catchFFeed e h
tryFFeed :: FFm a -> FFm (Either FFeedErr a)
tryFFeed f = handleFFeed (\ x -> return (Left x)) (f >>= return.Right)
throwFFeedErr :: FFeedErr -> FFm a
throwFFeedErr e = FFm (\ _ -> throwIO e)
catchFFeed :: FFm a -> (FFeedErr -> FFm a) -> FFm a
catchFFeed (FFm f) hdlr = FFm $ \ env ->
CE.catch (f env)
(\ e1 -> case hdlr e1 of { (FFm act) -> act env })
instance Show FFeedErr where
show x = unlines (
[ "FriendFeed error:"
, ""
, " Code: " ++ ffErrorCode x
, " Location: " ++ fromMaybe "<unknown>" (ffErrorLoc x)
, " Source: " ++ ffErrorSource x
])