module Facebook.Types
( Credentials(..)
, appIdBS
, appSecretBS
, AccessToken(..)
, UserAccessToken
, AppAccessToken
, AccessTokenData
, Id(..)
, UserId
, accessTokenData
, accessTokenExpires
, accessTokenUserId
, UserKind
, AppKind
, Argument
, (<>)
, FbUTCTime(..)
) where
import Control.Applicative ((<$>), (<*>), pure)
import Control.Monad (mzero)
import Data.ByteString (ByteString)
import Data.Int (Int64)
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid (Monoid, mappend)
#endif
import Data.String (IsString)
import Data.Text (Text)
import Data.Time (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Typeable (Typeable)
#if MIN_VERSION_time(1,5,0)
import Data.Time (defaultTimeLocale, parseTimeM)
#else
import System.Locale (defaultTimeLocale)
import Data.Time (parseTime)
#endif
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Builder as TLB
import qualified Data.Text.Lazy.Builder.Int as TLBI
data Credentials = Credentials
{ appName :: Text
, appId :: Text
, appSecret :: Text
} deriving (Eq, Ord, Show, Read, Typeable)
appIdBS :: Credentials -> ByteString
appIdBS = TE.encodeUtf8 . appId
appSecretBS :: Credentials -> ByteString
appSecretBS = TE.encodeUtf8 . appSecret
data AccessToken kind where
UserAccessToken ::
UserId -> AccessTokenData -> UTCTime -> AccessToken UserKind
AppAccessToken :: AccessTokenData -> AccessToken AppKind
type UserAccessToken = AccessToken UserKind
type AppAccessToken = AccessToken AppKind
deriving instance Eq (AccessToken kind)
deriving instance Ord (AccessToken kind)
deriving instance Show (AccessToken kind)
deriving instance Typeable AccessToken
type AccessTokenData = Text
newtype Id = Id
{ idCode :: Text
} deriving (Eq, Ord, Show, Read, Typeable, IsString)
instance A.FromJSON Id where
parseJSON (A.Object v) = v A..: "id"
parseJSON (A.String s) = pure $ Id s
parseJSON (A.Number d) = pure $ Id $ from $ floor d
where
from i = TL.toStrict $ TLB.toLazyText $ TLBI.decimal (i :: Int64)
parseJSON o = fail $ "Can't parse Facebook.Id from " ++ show o
instance A.ToJSON Id where
toJSON (Id t) = A.String t
type UserId = Id
accessTokenData :: AccessToken anyKind -> AccessTokenData
accessTokenData (UserAccessToken _ d _) = d
accessTokenData (AppAccessToken d) = d
accessTokenExpires :: AccessToken anyKind -> Maybe UTCTime
accessTokenExpires (UserAccessToken _ _ expt) = Just expt
accessTokenExpires (AppAccessToken _) = Nothing
accessTokenUserId :: UserAccessToken -> UserId
accessTokenUserId (UserAccessToken uid _ _) = uid
data UserKind
deriving (Typeable)
data AppKind
deriving (Typeable)
type Argument = (ByteString, ByteString)
#if !(MIN_VERSION_base(4,11,0))
(<>)
:: Monoid a
=> a -> a -> a
(<>) = mappend
#endif
instance A.ToJSON (AccessToken kind) where
toJSON (UserAccessToken uid data_ expires) =
A.object
[ "kind" A..= ("user" :: Text)
, "id" A..= uid
, "token" A..= data_
, "expires" A..= expires
]
toJSON (AppAccessToken data_) =
A.object ["kind" A..= ("app" :: Text), "token" A..= data_]
class ParseAccessToken kind where
parseTokenJSON :: A.Object -> A.Parser (AccessToken kind)
instance ParseAccessToken UserKind where
parseTokenJSON v = checkKind v "user" $ UserAccessToken <$> v A..: "id" <*> v A..: "token" <*> v A..: "expires"
instance ParseAccessToken AppKind where
parseTokenJSON v = checkKind v "app" $ AppAccessToken <$> v A..: "token"
checkKind :: A.Object -> Text -> A.Parser a -> A.Parser a
checkKind v kind ok = do
kind' <- v A..: "kind"
if kind == kind'
then ok
else fail $
"Expected access token kind " <> show kind <> " but found " <> show kind' <>
"."
instance ParseAccessToken kind =>
A.FromJSON (AccessToken kind) where
parseJSON (A.Object v) = parseTokenJSON v
parseJSON _ = mzero
newtype FbUTCTime = FbUTCTime
{ unFbUTCTime :: UTCTime
} deriving (Eq, Ord, Show, Read, Typeable)
instance A.FromJSON FbUTCTime where
parseJSON (A.String t) =
#if MIN_VERSION_time(1,5,0)
case parseTimeM True defaultTimeLocale "%FT%T%z" (T.unpack t) of
#else
case parseTime defaultTimeLocale "%FT%T%z" (T.unpack t) of
#endif
Just d -> return (FbUTCTime d)
_ -> fail $ "could not parse FbUTCTime string " ++ show t
parseJSON (A.Number n) =
return $ FbUTCTime $ posixSecondsToUTCTime $ fromInteger $ floor n
parseJSON _ =
fail
"could not parse FbUTCTime from something which is not a string or number"