{-# OPTIONS_GHC -XExistentialQuantification -XDeriveDataTypeable #-}
--------------------------------------------------------------------
-- |
-- Module      : FriendFeed.Monad
-- Description : Monadic layer for supporting friendfeed.com interactions.
-- Copyright   : (c) Sigbjorn Finne, 2008
-- License     : BSD3
--
-- Maintainer: Sigbjorn Finne <sof@forkIO.com>
-- Stability : provisional
-- Portability: portable
--
-- Monadic layer for handling calls and processing of FriendFeed API
-- interaction.
--------------------------------------------------------------------
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 = {-ffeedTranslate checkResponse-} (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 {-showJSValue x ""-}}))
     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 {-showJSValue x ""-}}))
     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
   ])