{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

module Web.Apiary.Authenticate.Internal where

import Control.Applicative((<$>), (<*>))
import Control.Monad(mzero)
import Control.Monad.Trans.Resource(runResourceT)
import Control.Monad.Apiary(ApiaryT, action)
import Control.Monad.Apiary.Filter(focus)
import Control.Monad.Apiary.Action(ActionT, getRequest, redirect)

import qualified Network.Wai as Wai
import qualified Network.HTTP.Types as HTTP
import qualified Network.HTTP.Client as Client
import qualified Web.Authenticate.OpenId as OpenId

import Web.Apiary(MonadIO(..))
import Web.Apiary.Session(Session, deleteSession, setSession)

import Data.Apiary.Extension(Has, Extension)
import Data.Proxy.Compat(Proxy(..))
import Data.Typeable(Typeable)
import Data.Apiary.Method(Method(GET))
import qualified Network.Routing as R

import qualified Data.Serialize as Serialize
import Data.Data (Data)
import Data.Maybe(mapMaybe)
import Data.Default.Class(Default(..))

import Blaze.ByteString.Builder(toByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.Text as T
import qualified Data.Text.Encoding as T


data AuthConfig = AuthConfig
    { authSuccessPage   :: S.ByteString
    , authUrl           :: T.Text

    , authPrefix        :: [T.Text]
    , authReturnToPath  :: [T.Text]
    , authLogoutPath    :: [T.Text]

    , providers         :: [(T.Text, Provider)]
    }

data Provider = Provider
    { providerUrl  :: T.Text
    , realm        :: Maybe T.Text
    , parameters   :: [(T.Text, T.Text)]
    }

instance Default AuthConfig where
    def = AuthConfig "/" "http://localhost:3000" ["auth"] ["return_to"] ["logout"] $ 
        [ ("google", Provider "https://www.google.com/accounts/o8/id" Nothing [])
        , ("yahoo",  Provider "http://me.yahoo.com/"                  Nothing [])
        ]

data Auth = Auth
    { manager           :: Client.Manager
    , config            :: AuthConfig
    }
instance Extension Auth

authHandler :: (Monad m, MonadIO actM, Has (Session OpenId actM) exts)
            => Auth -> ApiaryT exts prms actM m ()
authHandler Auth{..} = retH >> mapM_ (uncurry go) (providers config)
  where
    pfxPath p = focus id (Just GET) $ R.raw "" $ \d t -> do
        if t == p
        then return (d, [])
        else mzero

    retH = pfxPath (authPrefix config ++ authReturnToPath config) . action $
        returnAction manager (authSuccessPage config)

    go name Provider{..} = pfxPath (authPrefix config ++ [name]) . action $
        authAction manager providerUrl returnTo realm parameters

    returnTo = T.decodeUtf8 $ T.encodeUtf8 (authUrl config) `S.append`
        toByteString (HTTP.encodePathSegments (authPrefix config ++ authReturnToPath config))

authConfig :: Auth -> AuthConfig
authConfig = config

authProviders :: Auth -> [(T.Text, Provider)]
authProviders = providers . config

authRoutes :: Auth -> [(T.Text, S.ByteString)]
authRoutes auth =
    map (\(k,_) -> (k, toByteString . HTTP.encodePathSegments $ authPrefix (config auth) ++ [k])) $
    providers (config auth)

-- | delete session. since 0.7.0.0.
authLogout :: (Has (Session OpenId m) exts, Monad m) => ActionT exts prms m ()
authLogout = deleteSession (Proxy :: Proxy OpenId)

authAction :: MonadIO m => Client.Manager -> T.Text -> T.Text
           -> Maybe T.Text -> [(T.Text, T.Text)] -> ActionT exts prms m ()
authAction mgr uri returnTo realm prm = do
    fw <- liftIO . runResourceT $ OpenId.getForwardUrl uri returnTo realm prm mgr
    redirect $ T.encodeUtf8 fw

data OpenId_ a = OpenId_
    { opLocal :: a
    , params  :: [(a, a)]
    , claimed :: Maybe a
    } deriving (Show, Read, Eq, Ord, Data, Typeable, Functor)

instance Serialize.Serialize (OpenId_ S.ByteString) where
    put (OpenId_ loc prm cld) = do
        Serialize.put loc
        Serialize.put prm
        Serialize.put cld
    get = OpenId_ <$> Serialize.get <*> Serialize.get <*> Serialize.get

instance Serialize.Serialize (OpenId_ T.Text) where
    get = fmap (fmap T.decodeUtf8) Serialize.get
    put = Serialize.put . fmap T.encodeUtf8

type OpenId = OpenId_ T.Text

toOpenId :: OpenId.OpenIdResponse -> OpenId
toOpenId r = OpenId_ 
    (OpenId.identifier $ OpenId.oirOpLocal r)
    (OpenId.oirParams r)
    (OpenId.identifier <$> OpenId.oirClaimed r)

returnAction :: (MonadIO m, Has (Session OpenId m) exts)
             => Client.Manager -> S.ByteString -> ActionT exts prms m ()
returnAction mgr to = do
    q <- Wai.queryString <$> getRequest
    r <- liftIO . runResourceT $ OpenId.authenticateClaimed (mapMaybe queryElem q) mgr
    setSession Proxy (toOpenId r)
    redirect to
  where
    queryElem (_, Nothing) = Nothing
    queryElem (k, Just v)  = Just (T.decodeUtf8 k, T.decodeUtf8 v)