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

import Control.Applicative(Applicative((<*>), pure), (<$>))
import Control.Arrow(first, second)
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.UTF8 as L
import Control.Monad(mzero, ap)
import Control.Monad.Reader(MonadReader(..),ReaderT(..), mapReaderT)
import Control.Monad.Trans(MonadTrans(..))
import Control.Monad.Trans(MonadIO(liftIO))
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.Generics (Data, Typeable)
import Data.Ix (Ix)
import Data.List (intercalate, isPrefixOf, sortBy)
import Data.Maybe (fromJust)
import Data.Time.Clock.POSIX (POSIXTime)
import qualified Data.Map as Map
import Happstack.Crypto.MD5 ( md5, stringMD5)
import Happstack.Data (Default(..), Version(..),deriveAll, deriveNewData, deriveSerialize)
import Happstack.Facebook.FacebookT
import Happstack.State (Proxy(..))
import Happstack.Server
import HSP (XML,XMLMetaData)
import HSX.XMLGenerator(XMLGenT(..))
import Network.Browser (Form(..),formToRequest, request, browse)
import qualified Network.HTTP as HTTP
import Network.URI
import System.Time (ClockTime(TOD),getClockTime)
import Text.RJson -- FIXME: use different JSON library?
import Web.Routes.RouteT(RouteT)
import Web.Routes.MTL

data FacebookConfig = 
    FacebookConfig { apiKey     :: ApiKey
                   , appSecret  :: AppSecret
                   , appId      :: AppId
                   , canvasURL  :: URI
                   , canvasCallbackURL  :: URI
                   , tabURL     :: Maybe URI
                   , connectURL :: URI
                   }
    deriving (Show, Eq)

newtype ApiKey    = ApiKey    { unApiKey :: String }    deriving (Read, Show, Eq, Ord)
newtype AppSecret = AppSecret { unAppSecret :: String } deriving (Read, Show, Eq, Ord)
newtype AppId     = AppId     { unAppId :: String }     deriving (Read, Show, Eq, Ord)

newtype CallId = CallId Integer
    deriving (Enum, Eq, Integral, Num, Ord, Read, Real, Show, Ix)

-- |
$(deriveAll  [''Eq, ''Ord, ''Read, ''Show, ''Ix, ''Default]
  [d| newtype Flid = Flid { unFlid :: Integer }
      data    Sex  = Male | Female
   |])

newtype User = User { uid :: Integer }
      deriving (Eq, Ord, Read, Show, Ix, Typeable, Data)
$(deriveNewData [''User])
instance Version User
$(deriveSerialize ''User)

newtype Page = Page { pageId :: Integer }
      deriving (Eq, Ord, Read, Show, Ix, Typeable, Data)
$(deriveNewData [''Page])
instance Version Page
$(deriveSerialize ''Page)

instance Version Sex
$(deriveSerialize ''Sex)

instance Version Flid
$(deriveSerialize ''Flid)

$(deriveAll  [''Eq, ''Ord, ''Read, ''Show, ''Default]
  [d|
      data FriendList = FriendList { flid :: Flid, name :: String } 
   |])

instance Version FriendList
$(deriveSerialize ''FriendList)

$(deriveAll  [''Eq, ''Ord, ''Read, ''Show, ''Ix, ''Default]
  [d| newtype PhotoId = PhotoId { pid :: Integer } |])

$(deriveAll  [''Eq, ''Ord, ''Read, ''Show, ''Ix, ''Default]
  [d| newtype AlbumId = AlbumId { aid :: Integer } |])

type SessionKey = String

type Parameters = [(String, String)]

data UidRequired = UidRequired
data SessionRequired = SessionRequired
data None = None

class (Functor m, Monad m) => FacebookMethod m method where
    type FacebookResponse method
    toParams :: method -> m Parameters
    parseResponse :: Proxy (m method) -> String -> Either String (FacebookResponse method)

class (Functor m, Monad m) => HasFacebookConfig m where
    askFacebookConfig :: m FacebookConfig

class (Functor m, Monad m) => HasUser m where
    askUser    :: m User

class (Functor m, Monad m) => HasSessionKey m where
    askSessionKey :: m  SessionKey

class (Functor m, Monad m) => HasFacebookData d m where
    askFacebookData :: m d

-- |the State that lives in the facebook monad
data FacebookState d
    = FacebookState { fbConfig :: FacebookConfig -- our api id, etc,
                    , fbData   :: d   -- user specific information that facebook provides
                    }

instance (Functor m, Monad m) => HasFacebookConfig (FacebookT (FacebookState d) m) where
    askFacebookConfig = fbConfig <$> askFacebookState

instance (Functor m, Monad m) => HasFacebookData d (FacebookT (FacebookState d) m) where
    askFacebookData = fbData <$> askFacebookState

data FacebookStateU d
    = FacebookStateU { fbuConfig :: FacebookConfig -- our api id, etc,
                     , fbuData   :: d   -- user specific information that facebook provides
                     , fbuUser   :: User
                     }

instance (Functor m, Monad m) => HasFacebookConfig (FacebookT (FacebookStateU d) m) where
    askFacebookConfig = fbuConfig <$> askFacebookState

instance (Functor m, Monad m) => HasFacebookData d (FacebookT (FacebookStateU d) m) where
    askFacebookData = fbuData <$> askFacebookState

instance (Functor m, Monad m) => HasUser (FacebookT (FacebookStateU d) m) where
    askUser   = fbuUser <$> askFacebookState

data FacebookStateS d
    = FacebookStateS { fbsConfig     :: FacebookConfig -- our api id, etc,
                     , fbsData       :: d   -- user specific information that facebook provides
                     , fbsUser       :: User
                     , fbsSessionKey :: SessionKey
                     }


instance (Functor m, Monad m) => HasFacebookConfig (FacebookT (FacebookStateS d) m) where
    askFacebookConfig = fbsConfig <$> askFacebookState

instance (Functor m, Monad m) => HasFacebookData d (FacebookT (FacebookStateS d) m) where
    askFacebookData = fbsData <$> askFacebookState

instance (Functor m, Monad m) => HasUser (FacebookT (FacebookStateS d) m) where
    askUser = fbsUser <$> askFacebookState

instance (Functor m, Monad m) => HasSessionKey (FacebookT (FacebookStateS d) m) where
    askSessionKey = fbsSessionKey <$> askFacebookState


-- ** XMLGenT 


instance (HasFacebookConfig m) => (HasFacebookConfig (XMLGenT m)) where
    askFacebookConfig = XMLGenT $ askFacebookConfig

instance (HasFacebookData d m) => (HasFacebookData d (XMLGenT m)) where
    askFacebookData = XMLGenT $ askFacebookData

instance (HasUser m) => (HasUser (XMLGenT m)) where
    askUser = XMLGenT $ askUser

instance (HasSessionKey m) => (HasSessionKey (XMLGenT m)) where
    askSessionKey = XMLGenT $ askSessionKey


-- ** ServerPartT 

instance (HasFacebookData d m) => HasFacebookData d (ServerPartT m) where
    askFacebookData = lift askFacebookData

instance (HasFacebookConfig m) => HasFacebookConfig (ServerPartT m) where
    askFacebookConfig = lift askFacebookConfig

instance (HasUser m) => HasUser (ServerPartT m) where
    askUser = lift askUser

instance (HasSessionKey m) => HasSessionKey (ServerPartT m) where
    askSessionKey = lift askSessionKey

-- ** RouteT

instance (HasFacebookData d m) => HasFacebookData d (RouteT u m) where
    askFacebookData = lift askFacebookData    

instance (HasFacebookConfig m) => HasFacebookConfig (RouteT url m) where
    askFacebookConfig = lift askFacebookConfig

instance (HasUser m) => HasUser (RouteT url m) where
    askUser = lift askUser

instance (HasSessionKey m) => HasSessionKey (RouteT url m) where
    askSessionKey = lift askSessionKey

assocToJSON :: [(String, String)] -> JsonData
assocToJSON assoc = JDObject $ Map.fromList (map (second toJson) assoc)

parseResponseBool :: String -> Either String Bool
parseResponseBool str =
    case fromJsonString [] str of
      (Right [b]) -> Right b
      (Left e)    -> Left e

parseUserIds :: String -> Either String [User]
parseUserIds str = 
    case partitionEithers $ map (fmap User . read') (commas str)  of
      ([], users) -> Right users
      (errors,_) -> Left $ show errors
    where
      commas :: String -> [String]
      commas = words . map (\c -> if (c==',') then ' ' else c)
      read' str = case reads str of
                    [(a,[])] -> Right a
                    r -> Left ("Failed to read " ++ str ++ " got " ++ show r)


-- |helper function
lookupBool :: String -> [(String, String)] -> Bool
lookupBool key assoc =
    case lookup key assoc of
      Nothing -> error ("required key " ++ key ++ " was not found.")
      (Just "0") -> False
      (Just "1") -> True
      (Just str) -> error ("key " ++ key ++ " has unparsable value " ++ str)

lookupMBool :: String -> [(String, String)] -> Maybe Bool
lookupMBool key assoc =
    case lookup key assoc of
      Nothing -> Nothing
      (Just "0") -> Just False
      (Just "1") -> Just True
      (Just str) -> Nothing 

toCommaList :: [String] -> String
toCommaList = intercalate ","

class RequiresSession a

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

buildRequest :: FacebookConfig -> Parameters -> (CallId -> HTTP.Request String)
buildRequest fbConfig parameters =
    \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"

buildRequestM :: (HasFacebookConfig m) => Parameters -> m (CallId -> HTTP.Request String)
buildRequestM parameters = 
    do c <- askFacebookConfig 
       return $ buildRequest c parameters

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

callMethod :: forall method m. (HasFacebookConfig m, MonadIO m, FacebookMethod m method) => method -> m (Either FacebookError (FacebookResponse method))
callMethod method =
    do configData <- askFacebookConfig
       params     <- toParams method
       req <- return $ buildRequest configData params
       -- liftIO (putStrLn $ "FB Request: " ++ (show $  req (CallId 0)))
       res <- execRequest req
       -- liftIO (putStrLn $ "FB Response: " ++ (show res))
       return $ parseResponse' (Proxy :: Proxy (m method)) res 

callMethodWithConfig :: forall method m. (MonadIO m, FacebookMethod m method) => FacebookConfig -> method -> m (Either FacebookError (FacebookResponse method))
callMethodWithConfig configData method =
    do params     <- toParams method
       req <- return $ buildRequest configData params
       -- liftIO (putStrLn $ "FB Request: " ++ (show $  req (CallId 0)))
       res <- execRequest req
       -- liftIO (putStrLn $ "FB Response: " ++ (show res))
       return $ parseResponse' (Proxy :: Proxy (m method)) res 

callMethodOld :: forall method m. (HasFacebookConfig m, MonadIO m, FacebookMethod m method) => method -> m (Either String (FacebookResponse method))
callMethodOld method =
    do configData <- askFacebookConfig
       params     <- toParams method
       req <- return $ buildRequest configData params
       -- liftIO (putStrLn $ "FB Request: " ++ (show $  req (CallId 0)))
       res <- execRequest req
       -- liftIO (putStrLn $ "FB Response: " ++ (show res))
       return $ parseResponse (Proxy :: Proxy (m method)) res 


-- |calculate the sig, and return the args in sorted order. The sig is *not* added to the args.
signature :: AppSecret -> [(String, String)] -> (String, [(String, String)])
signature (AppSecret appSecret) unsortedArgs =
    let args = sortBy (compare `on` fst) unsortedArgs
        argStr = concatMap (\(k,v) -> k ++ '=' : v) args
        sig = stringMD5 (md5 (L.pack (argStr ++ appSecret)))
    in (sig, args)


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

parseResponse' :: (FacebookMethod m method) => Proxy (m 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


data ActionLink = ActionLink String String
      deriving (Data, Typeable, Eq, Ord, Read, Show)

actionLinkToJSON (ActionLink text uri) =
        JDObject $ Map.fromList [ ("text", (toJson text))
                                , ("href", (toJson uri))
                                ]


newtype FbXML = FbXML { unFbXML :: XML }


-- FIXME: the <style> and <script> tags should be encoded like html not xhtml
{-
instance ToMessage FbXML where
    toContentType _ = P.pack "application/xml; charset=utf-8"
    toMessage (FbXML xml) = L.fromString (renderAsFBML xml)

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

instance ToMessage FbXML where
    toContentType _ = P.pack "text/html; charset=utf-8"
    toMessage (FbXML xml) = L.fromString (renderAsFBML xml)

instance ToMessage (Maybe XMLMetaData, FbXML) where
    toContentType _ = P.pack "text/html; charset=utf-8"
    toMessage (_,FbXML xml) = L.fromString (renderAsFBML xml)

withFacebook' :: (Functor m, Monad m) => FacebookConfig -> d -> FacebookT (FacebookState d) m a -> m a
withFacebook' config facebookData m = runReaderT (unFacebookT m) (FacebookState config facebookData)

-- |function to read some FacebookConnectData from the Facebook environment
fbd :: (HasFacebookData d m) => (d -> a) -> m a
fbd select = 
    do d <- askFacebookData
       return (select d)


-- TODO: figure how to implement this so that it can be called when the FacebookT is embed inside other monad transformers
withUser ::
  ( HasFacebookConfig (FacebookT r m)
  , HasFacebookData d (FacebookT r m)
  ) 
  => User -> FacebookT (FacebookStateU d) m a -> FacebookT r m a
withUser u (FacebookT action) =
    do c <- askFacebookConfig
       d <- askFacebookData
       FacebookT $ ReaderT $ const (runReaderT action (FacebookStateU c d u))

withSession :: (HasUser (FacebookT (s d) m), HasFacebookData d (FacebookT (s d) m), HasFacebookConfig (FacebookT (s d) m)) => 
             SessionKey 
            -> FacebookT (FacebookStateS d) m a 
            -> FacebookT (s d) m a
withSession s (FacebookT action) =
    do c <- askFacebookConfig
       d <- askFacebookData
       u <- askUser
       FacebookT $ ReaderT $ const $ runReaderT action (FacebookStateS c d u s)
--        FacebookT $ ReaderT (runReaderT action (FacebookStateS c d u s))