{-# 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 GHC.Generics(Generic)

import Control.Applicative
import Control.Monad.Trans.Resource
import Control.Monad.Apiary.Filter
import Control.Monad.Apiary.Action

import qualified Network.HTTP.Types as HTTP
import qualified Network.HTTP.Client as Client

import Web.Authenticate.OpenId
import Web.Apiary
import Web.Apiary.ClientSession
import qualified Web.Apiary.Wai as Wai

import Data.Binary as Binary
import Data.Data (Data)
import Data.Maybe
import Data.List
import Data.Apiary.Compat
import Data.Apiary.Param
import Data.Default.Class

import Blaze.ByteString.Builder
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy as L
import qualified Data.Text as T
import qualified Data.Text.Encoding as T


data AuthConfig = AuthConfig
    { authSessionName   :: S.ByteString
    , authSuccessPage   :: S.ByteString
    , authSessionConfig :: SessionConfig
    , 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 "_ID" "/" def "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
    }

authHandler :: (Monad m, MonadIO actM, Has Session exts)
            => Auth -> ApiaryT exts prms actM m ()
authHandler Auth{..} = retH >> mapM_ (uncurry go) (providers config)
  where
    pfxPath p = function id (\d r -> if p `isPrefixOf` Wai.pathInfo r then Just d else Nothing)

    retH = pfxPath (authPrefix config ++ authReturnToPath config) . method GET . action $
        returnAction (authSessionConfig config) manager (authSessionName config) (authSuccessPage config)

    go name Provider{..} = pfxPath (authPrefix config ++ [name]) . method GET . 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)

authLogout :: Monad m => Auth -> ActionT exts prms m ()
authLogout auth = deleteCookie (authSessionName $ config auth)

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 $ 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, Generic, Functor)
instance Binary (OpenId_ S.ByteString)

instance Binary (OpenId_ T.Text) where
    get   = fmap (fmap T.decodeUtf8) (Binary.get :: Get (OpenId_ S.ByteString))
    put g = put (fmap T.encodeUtf8 g)

instance Query (OpenId_ T.Text) where
    readQuery Nothing  = Nothing
    readQuery (Just s) = case decodeOrFail (L.fromStrict s) of
        Right (s',_,a) | L.null s' -> Just a
        _                          -> Nothing
    qTypeRep = typeRep

type OpenId = OpenId_ T.Text

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

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