{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleContexts, ScopedTypeVariables, TemplateHaskell, TypeFamilies, TypeSynonymInstances, UndecidableInstances #-}
{-# OPTIONS_GHC -F -pgmFtrhsx #-}
module Happstack.Facebook where

import Control.Applicative(Applicative((<*>), pure),(<$>))
import Control.Arrow(first, second)
import Control.Monad (ap, liftM, when)
import Control.Monad.Trans (MonadTrans,MonadIO,lift, liftIO)
import Control.Monad.State (MonadState,StateT,evalStateT,get, put)
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.UTF8 as L
import Data.Either (partitionEithers)
import Data.Function (on)
import Data.Ix(Ix)
import Data.List
import qualified Data.Map as Map
import Data.Generics (Data, Typeable)
import Data.List (isPrefixOf, sortBy)
import Data.Maybe (catMaybes, isJust, fromJust)
import Data.Time.Clock.POSIX (POSIXTime)
import Debug.Trace(trace, traceShow)
import Happstack.Data (Default(..), Version(..),deriveAll, deriveNewData, deriveSerialize)
import Happstack.Server (ServerPartT(ServerPartT), ToMessage(toMessage, toContentType), 
                     WebT(WebT), Response, toResponse, withDataFn, Method(..), mapServerPartT,
                     seeOther)
import Happstack.Crypto.MD5 ( md5, stringMD5)
import HSP
import HSP.Identity (evalIdentity)
import HSP (HSPT,XML,XMLMetaData,evalHSPT,renderXML)
import Happstack.Server.Extra (lookPairsUnicode)
import qualified Network.HTTP as HTTP
import Network.Browser (Form(..),formToRequest, request, browse)
import Network.URI (URI,parseURI,uriToString)
import System.Time (ClockTime(TOD),getClockTime)
import Text.RJson -- FIXME: use different JSON library?


type FacebookMethodString = String

-- normally we would just derive this, but trhsx can't handle it
-- (haddock used to break as well, I wonder if that is fixed now?)
instance (Monad m) => MonadState FacebookState (FacebookT m) where
    get = FacebookT get
    put s = FacebookT (put s)

modifyFBS :: (MonadState s m) => (s -> s) -> FacebookT m s
modifyFBS f =
    do fbs <- FacebookT (lift get)
       FacebookT (lift (put (f fbs)))
       return fbs

callId :: Facebook CallId
callId = 
    do (TOD x y) <- liftIO getClockTime
       return (CallId (x + y))

{-
instance ToMessage (Maybe XMLMetaData, XML) where
    toContentType _ = P.pack "application/xml; charset=utf-8"
    toMessage (_,xml) = L.fromString (renderXML xml)

instance ToMessage XML where
    toContentType _ = P.pack "application/xml; charset=utf-8"
    toMessage xml = L.fromString (renderXML xml)
-}

facebook :: FacebookConfig -> FacebookData -> Facebook XML -> WebT IO Response
facebook config fbData fb =
    do a <- liftIO $ evalStateT (unFacebookT (evalHSPT Nothing fb)) (FacebookState config fbData)
       return (toResponse (second FbXML a))


-- |redirect to login if no session key is found
requireLogin :: URI -- ^ where to go after the login
             -> ServerPartT Facebook XML -> ServerPartT Facebook XML
requireLogin next sp =
    do mSessionKey <- lift fb_sig_session_key
       if isJust mSessionKey
          then sp
          else do key <- unApiKey . apiKey . fbConfig <$> lift getFBS
                  let uri = "http://www.facebook.com/login.php?v=1.0&api_key=" ++ 
                            key ++"&next=" ++ uriToString id next "&canvas="
                  seeOther uri (evalIdentity <fb:redirect url=uri />)

-- * Utility Functions
{-
assocToJSON :: [(String, String)] -> JsonData
assocToJSON assoc = JDArray $ map toAssoc assoc
    where
      toAssoc (k, v) = JDObject (Map.singleton k (toJson v))
-}

-- * API



buildRequest :: Parameters -> Facebook (CallId -> HTTP.Request String)
buildRequest parameters = 
    do fbConfig <- liftM fbConfig getFBS
       uid <- liftM (maybe "" (show . uid)) fb_user -- FIXME : not all calls require this
       return $ \cid ->
           let (sig, args) = signature (appSecret fbConfig) $
                      [ ("api_key", unApiKey $ apiKey fbConfig)
                      , ("call_id", show (toInteger cid))
                      , ("format","json")
                      , ("uid", uid)
                      , ("v","1.0")
                      ] ++ parameters
           in formToRequest (Form HTTP.POST fbRESTURI (args ++ [("sig",sig)]))
    where
      fbRESTURI :: URI
      fbRESTURI = fromJust $ parseURI "http://api.facebook.com/restserver.php"


execRequest :: (CallId -> HTTP.Request String) -> Facebook String
execRequest req =
    do cid <- callId
       (_uri, res) <- liftIO $ browse (request (req cid))
       let body = HTTP.rspBody res
       return body



callMethod :: forall method. (FacebookMethod method) => method -> Facebook (FacebookResponse method)
callMethod method =
    do res <- callMethodE method
       case res of
         Left e -> error (show e)
         Right r -> return $ r

callMethodE :: forall method. (FacebookMethod method) => method -> Facebook (Either FacebookError (FacebookResponse method))
callMethodE method =
    do req <- buildRequest =<< toParams method
       liftIO (putStrLn $ "FB Request: " ++ (show $  req (CallId 0)))
       res <- execRequest req
       liftIO (putStrLn $ "FB Response: " ++ (show res))
       return $ parseResponse' (Proxy :: Proxy method) res 

data FacebookError
    = FacebookError
      { error_code :: Integer
      , error_msg  :: String
      , request_args :: Parameters
      }
    | ParseError String
      deriving (Eq, Ord, Read, Show)

parseResponse' :: (FacebookMethod method) => Proxy method -> String -> Either FacebookError (FacebookResponse method)
parseResponse' method responseString
    | "{\"error_code\":" `isPrefixOf` responseString =
        Left (parseError responseString)
    | otherwise = 
        case parseResponse method responseString of
          (Left str) -> Left (ParseError str)
          (Right r)  -> Right r

parseError :: String -> FacebookError
parseError responseString =
    case parseJsonString responseString of
      (Left e) -> ParseError e
      (Right (JDObject json)) -> 
          FacebookError { error_code = 
                            let (Just (JDNumber d))    = Map.lookup "error_code" json
                            in floor d
                        , error_msg = 
                            let (Just (JDString str))  = Map.lookup "error_msg" json
                            in str
                        , request_args =
                            let (Just (JDArray args)) = Map.lookup "request_args" json
                            in map fromKeyValue args
                        }
    where
      fromKeyValue :: JsonData -> (String, String)
      fromKeyValue (JDObject json) = (fromJD $ fromJust $ Map.lookup "key" json, fromJD $ fromJust $ Map.lookup "value" json)
      fromJD (JDString str) = str
      fromJD (JDNumber d) = show d