{-# LANGUAGE FlexibleContexts, GADTs, ScopedTypeVariables,
  OverloadedStrings #-}

module Facebook.Auth
  ( getAppAccessToken
  , getUserAccessTokenStep1
  , getUserAccessTokenStep2
  , getUserLogoutUrl
  , extendUserAccessToken
  , RedirectUrl
  , Permission
  , unPermission
  , hasExpired
  , isValid
  , parseSignedRequest
  , debugToken
  , DebugToken(..)
  ) where
#if __GLASGOW_HASKELL__ <= 784
import Control.Applicative
#endif
import Control.Monad (guard, join, liftM, mzero)
import Control.Monad.IO.Class (MonadIO(liftIO))
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Crypto.Classes (constTimeEq)
import Crypto.Hash.CryptoAPI (SHA256)
import Crypto.HMAC (hmac', MacKey(..))
import Data.Aeson ((.:))
import Data.Aeson.Parser (json')
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Time (getCurrentTime, addUTCTime, UTCTime)
import Data.Typeable (Typeable)
import Data.String (IsString(..))

import qualified Control.Exception.Lifted as E
import qualified Control.Monad.Trans.Resource as R
import qualified Data.Aeson as AE
import qualified Data.Aeson.Types as AE
import qualified Data.Attoparsec.ByteString.Char8 as AB
import qualified Data.Attoparsec.Text as A
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Base64.URL as Base64URL
import qualified Data.ByteString.Char8 as B8
import qualified Data.Conduit as C
import qualified Data.Conduit.Attoparsec as C
import qualified Data.Conduit.Text as CT
import qualified Data.List as L
import qualified Data.Serialize as Cereal
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TE
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
import Data.Text (Text)

import Facebook.Types
import Facebook.Base
import Facebook.Monad

-- | Get an app access token from Facebook using your
-- credentials.
-- Ref: https://developers.facebook.com/docs/facebook-login/manually-build-a-login-flow
getAppAccessToken
  :: (R.MonadResource m, MonadBaseControl IO m)
  => FacebookT Auth m AppAccessToken
getAppAccessToken =
  runResourceInFb $
  do creds <- getCreds
     req <-
       fbreq "/oauth/access_token" Nothing $
       tsq creds [("grant_type", "client_credentials")]
     response <- fbhttp req
     (token :: AE.Value) <- asJson response
     case AE.parseMaybe tokenParser token of
       Just appToken -> return $ AppAccessToken appToken
       _ ->
         E.throw $
         FbLibraryException ("Unable to parse: " <> (T.pack $ show token))
  where
    tokenParser :: AE.Value -> AE.Parser AccessTokenData
    tokenParser val =
      AE.withObject
        "accessToken"
        (\obj -> do
           (token :: Text) <- obj AE..: "access_token"
           return token)
        val

-- | The first step to get an user access token.  Returns the
-- Facebook URL you should redirect you user to.  Facebook will
-- authenticate the user, authorize your app and then redirect
-- the user back into the provider 'RedirectUrl'.
getUserAccessTokenStep1
  :: Monad m
  => RedirectUrl -> [Permission] -> FacebookT Auth m Text
getUserAccessTokenStep1 redirectUrl perms = do
  creds <- getCreds
  withTier $
    \tier ->
       let urlBase =
             case tier of
               Production ->
                 "https://www.facebook.com/" <> apiVersion <>
                 "/dialog/oauth?client_id="
               Beta ->
                 "https://www.beta.facebook.com/" <> apiVersion <>
                 "/dialog/oauth?client_id="
       in T.concat $
          urlBase :
          appId creds :
          "&redirect_uri=" :
          redirectUrl :
          (case perms of
             [] -> []
             _ -> "&scope=" : L.intersperse "," (map unPermission perms))

-- | The second step to get an user access token.  If the user is
-- successfully authenticate and they authorize your application,
-- then they'll be redirected back to the 'RedirectUrl' you've
-- passed to 'getUserAccessTokenStep1'.  You should take the
-- request query parameters passed to your 'RedirectUrl' and give
-- to this function that will complete the user authentication
-- flow and give you an @'UserAccessToken'@.
getUserAccessTokenStep2
  :: (MonadBaseControl IO m, R.MonadResource m)
  => RedirectUrl -- ^ Should be exactly the same
     -- as in 'getUserAccessTokenStep1'.
  -> [Argument] -- ^ Query parameters.
  -> FacebookT Auth m UserAccessToken
getUserAccessTokenStep2 redirectUrl query =
  case query of
    [code@("code", _)] ->
      runResourceInFb $
      -- Get the access token data through Facebook's OAuth.
      do now <- liftIO getCurrentTime
         creds <- getCreds
         req <-
           fbreq "/oauth/access_token" Nothing $
           tsq creds [code, ("redirect_uri", TE.encodeUtf8 redirectUrl)]
         response <- fbhttp req
         (userToken :: AE.Value) <- asJson response
         let (token, expire) = userAccessTokenParser now userToken
         -- Get user's ID throught Facebook's graph.
         userResponse <-
           fbhttp =<<
           fbreq
             "/me"
             (Just (UserAccessToken "invalid id" token expire))
             [("fields", "id")]
         (userId :: UserId) <- asJson userResponse
         return $ UserAccessToken userId token expire
    _ ->
      let [error_, errorReason, errorDescr] =
            map
              (fromMaybe "" . flip lookup query)
              ["error", "error_reason", "error_description"]
          errorType = T.concat [t error_, " (", t errorReason, ")"]
          t = TE.decodeUtf8With TE.lenientDecode
      in E.throw $ FacebookException errorType (t errorDescr)

-- | Attoparsec parser for user access tokens returned by
-- Facebook as a query string.  Returns an user access token with
-- a broken 'UserId'.
userAccessTokenParser
  :: UTCTime -- ^ 'getCurrentTime'
  -> AE.Value
  -> (AccessTokenData, UTCTime)
userAccessTokenParser now val =
  case AE.parseMaybe tokenParser val of
    Just (token, parser) -> (token, parser)
    _ -> error $ "userAccessTokenParser: failed to parse " ++ show val
  where
    toExpire expt = addUTCTime (fromIntegral expt) now
    tokenParser :: AE.Value -> AE.Parser (AccessTokenData, UTCTime)
    tokenParser val =
      AE.withObject
        "accessToken"
        (\obj -> do
           (token :: Text) <- obj AE..: "access_token"
           (expires_in :: Int) <- obj AE..: "expires_in"
           return (token, toExpire expires_in))
        val

-- | The URL an user should be redirected to in order to log them
-- out of their Facebook session.  Facebook will then redirect
-- the user to the provided URL after logging them out.  Note
-- that, at the time of this writing, Facebook's policies require
-- you to log the user out of Facebook when they ask to log out
-- of your site.
--
-- Note also that Facebook may refuse to redirect the user to the
-- provided URL if their user access token is invalid.  In order
-- to prevent this bug, we suggest that you use 'isValid' before
-- redirecting the user to the URL provided by 'getUserLogoutUrl'
-- since this function doesn't do any validity checks.
getUserLogoutUrl
  :: Monad m
  => UserAccessToken
     -- ^ The user's access token.
  -> RedirectUrl
     -- ^ URL the user should be directed to in
     -- your site domain.
  -> FacebookT Auth m Text -- ^ Logout URL in
-- @https:\/\/www.facebook.com\/@ (or on
-- @https:\/\/www.beta.facebook.com\/@ when
-- using the beta tier).
getUserLogoutUrl (UserAccessToken _ data_ _) next = do
  withTier $
    \tier ->
       let urlBase =
             case tier of
               Production -> "https://www.facebook.com/logout.php?"
               Beta -> "https://www.beta.facebook.com/logout.php?"
       in TE.decodeUtf8 $
          urlBase <>
          HT.renderQuery
            False
            [ ("next", Just (TE.encodeUtf8 next))
            , ("access_token", Just (TE.encodeUtf8 data_))
            ]

-- | URL where the user is redirected to after Facebook
-- authenticates the user authorizes your application.  This URL
-- should be inside the domain registered for your Facebook
-- application.
type RedirectUrl = Text

-- | A permission that is asked for the user when he authorizes
-- your app.  Please refer to Facebook's documentation at
-- <https://developers.facebook.com/docs/reference/api/permissions/>
-- to see which permissions are available.
--
-- This is a @newtype@ of 'Text' that supports only 'IsString'.
-- This means that to create a 'Permission' you should use the
-- @OverloadedStrings@ language extension.  For example,
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > perms :: [Permission]
-- > perms = ["user_about_me", "email", "offline_access"]
newtype Permission = Permission
  { unPermission :: Text
    -- ^ Retrieves the 'Text' back from a 'Permission'.  Most of
    -- the time you won't need to use this function, but you may
    -- need it if you're a library author.
  } deriving (Eq, Ord)

instance Show Permission where
  show = show . unPermission

instance IsString Permission where
  fromString = Permission . fromString

-- | @True@ if the access token has expired, otherwise @False@.
hasExpired
  :: (Functor m, MonadIO m)
  => AccessToken anyKind -> m Bool
hasExpired token =
  case accessTokenExpires token of
    Nothing -> return False
    Just expTime -> (>= expTime) <$> liftIO getCurrentTime

-- | @True@ if the access token is valid.  An expired access
-- token is not valid (see 'hasExpired').  However, a non-expired
-- access token may not be valid as well.  For example, in the
-- case of an user access token, they may have changed their
-- password, logged out from Facebook or blocked your app.
isValid
  :: (MonadBaseControl IO m, R.MonadResource m)
  => AccessToken anyKind -> FacebookT anyAuth m Bool
isValid token = do
  expired <- hasExpired token
  if expired
    then return False
    else let page =
               case token of
                 UserAccessToken _ _ _ -> "/me"
                 -- Documented way of checking if the token is valid,
                 -- see <https://developers.facebook.com/blog/post/500/>.
                 AppAccessToken _ -> "/19292868552"
             -- This is Facebook's page on Facebook.  While
             -- this behaviour is undocumented, it will
             -- return a "400 Bad Request" status code
             -- whenever the access token is invalid.  It
             -- will actually work with user access tokens,
             -- too, but they have another, better way of
             -- being checked.
         in httpCheck =<< fbreq page (Just token) []

-- | Extend the expiration time of an user access token (see
-- <https://developers.facebook.com/docs/offline-access-deprecation/>,
-- <https://developers.facebook.com/roadmap/offline-access-removal/>).
-- Only short-lived user access tokens may extended into
-- long-lived user access tokens, you must get a new short-lived
-- user access token if you need to extend a long-lived
-- one.  Returns @Left exc@ if there is an error while extending,
-- or @Right token@ with the new user access token (which could
-- have the same data and expiration time as before, but you
-- can't assume this).  Note that expired access tokens can't be
-- extended, only valid tokens.
extendUserAccessToken
  :: (MonadBaseControl IO m, R.MonadResource m)
  => UserAccessToken
  -> FacebookT Auth m (Either FacebookException UserAccessToken)
extendUserAccessToken token@(UserAccessToken uid data_ _) = do
  expired <- hasExpired token
  if expired
    then return (Left hasExpiredExc)
    else tryToExtend
  where
    tryToExtend =
      runResourceInFb $
      do creds <- getCreds
         req <-
           fbreq "/oauth/access_token" Nothing $
           tsq
             creds
             [ ("grant_type", "fb_exchange_token")
             , ("fb_exchange_token", TE.encodeUtf8 data_)
             ]
         response <- fbhttp req
         userToken <- E.try $ asJson response
         case userToken of
           Right val -> do
             now <- liftIO getCurrentTime
             let (extendedtoken, expire) = userAccessTokenParser now val
             return $ Right $ UserAccessToken uid extendedtoken expire
           Left exc -> return (Left exc)
    hasExpiredExc =
      mkExc
        [ "the user access token has already expired, "
        , "so I'll not try to extend it."
        ]
    mkExc = FbLibraryException . T.concat . ("extendUserAccessToken: " :)

-- | Parses a Facebook signed request
-- (<https://developers.facebook.com/docs/authentication/signed_request/>),
-- verifies its authencity and integrity using the HMAC and
-- decodes its JSON object.
parseSignedRequest
  :: (AE.FromJSON a, Monad m)
  => B8.ByteString -- ^ Encoded Facebook signed request
  -> FacebookT Auth m (Maybe a)
parseSignedRequest signedRequest =
  runMaybeT $
  -- Split, decode and JSON-parse
  do let (encodedSignature, encodedUnparsedPayloadWithDot) = B8.break (== '.') signedRequest
     ('.', encodedUnparsedPayload) <-
       MaybeT $ return (B8.uncons encodedUnparsedPayloadWithDot)
     signature <- eitherToMaybeT $ Base64URL.decode $ addBase64Padding encodedSignature
     unparsedPayload <- eitherToMaybeT $ Base64URL.decode $ addBase64Padding encodedUnparsedPayload
     payload <- eitherToMaybeT $ AB.parseOnly json' unparsedPayload
     -- Verify signature
     SignedRequestAlgorithm algo <- fromJson payload
     guard (algo == "HMAC-SHA256")
     hmacKey <- credsToHmacKey `liftM` lift getCreds
     let expectedSignature = Cereal.encode $ hmac' hmacKey encodedUnparsedPayload
     guard (signature `constTimeEq` expectedSignature)
     -- Parse user data type
     fromJson payload
  where
    eitherToMaybeT
      :: Monad m
      => Either a b -> MaybeT m b
    eitherToMaybeT = MaybeT . return . either (const Nothing) Just
    fromJson
      :: (AE.FromJSON a, Monad m)
      => AE.Value -> MaybeT m a
    fromJson = eitherToMaybeT . AE.parseEither AE.parseJSON
    credsToHmacKey :: Credentials -> MacKey ctx SHA256
    credsToHmacKey = MacKey . appSecretBS

newtype SignedRequestAlgorithm =
  SignedRequestAlgorithm Text

instance AE.FromJSON SignedRequestAlgorithm where
  parseJSON (AE.Object v) = SignedRequestAlgorithm <$> v .: "algorithm"
  parseJSON _ = mzero

-- | The @base64-bytestring@ package provides two different
-- decoding functions for @base64url@: 'Base64URL.decode' and
-- 'Base64URL.decodeLenient'.  The former is too strict for us
-- since Facebook does add padding to its signed requests, but
-- the latter is too lenient and will accept *anything*.
--
-- Instead of being too lenient, we just use this function add
-- the padding base to the encoded string, thus allowing
-- 'Base64URL.decode' to chew it.
addBase64Padding :: B.ByteString -> B.ByteString
addBase64Padding bs
  | drem == 2 = bs `B.append` "=="
  | drem == 3 = bs `B.append` "="
  | otherwise = bs
  where
    drem = B.length bs `mod` 4

-- | Get detailed information about an access token.
debugToken
  :: (MonadBaseControl IO m, R.MonadResource m)
  => AppAccessToken -- ^ Your app access token.
  -> AccessTokenData -- ^ The access token you want to debug.
  -> FacebookT Auth m DebugToken
debugToken appToken userTokenData = do
  req <-
    fbreq "/debug_token" (Just appToken) $
    [("input_token", TE.encodeUtf8 userTokenData)]
  ret <- undata <$> (asJson =<< fbhttp req)
  let muserToken =
        UserAccessToken <$> dtUserId ret <*> return userTokenData <*>
        dtExpiresAt ret
  return
    ret
    { dtAccessToken = muserToken
    }

-- | Helper used in 'debugToken'.  Unfortunately, we can't use 'Pager' here.
data Undata a = Undata
  { undata :: a
  }

instance AE.FromJSON a =>
         AE.FromJSON (Undata a) where
  parseJSON (AE.Object v) = Undata <$> v AE..: "data"
  parseJSON _ = mzero

-- | Detailed information about an access token (cf. 'debugToken').
data DebugToken = DebugToken
  { dtAppId :: Maybe Text
  , dtAppName :: Maybe Text
  , dtExpiresAt :: Maybe UTCTime
  , dtIsValid :: Maybe Bool
  , dtIssuedAt :: Maybe UTCTime
  , dtScopes :: Maybe [Permission]
  , dtUserId :: Maybe Id
  , dtAccessToken :: Maybe UserAccessToken
  } deriving (Eq, Ord, Show, Typeable)

-- | Note: this instance always sets 'dtAccessToken' to
-- 'Nothing', but 'debugToken' will update this field before
-- returning the final 'DebugToken'.  This is done because we
-- need the 'AccessTokenData', which is not part of FB's
-- response.
instance AE.FromJSON DebugToken where
  parseJSON (AE.Object v) =
    DebugToken <$> (fmap idCode <$> v AE..:? "app_id") <*>
    v AE..:? "application" <*>
    (fmap unFbUTCTime <$> v AE..:? "expires_at") <*>
    v AE..:? "is_valid" <*>
    (fmap unFbUTCTime <$> v AE..:? "issued_at") <*>
    (fmap (map Permission) <$> v AE..:? "scopes") <*>
    v AE..:? "user_id" <*>
    pure Nothing
  parseJSON _ = mzero