diff --git a/apiary-authenticate.cabal b/apiary-authenticate.cabal --- a/apiary-authenticate.cabal +++ b/apiary-authenticate.cabal @@ -1,5 +1,5 @@ name: apiary-authenticate -version: 0.14.1 +version: 0.16.0 synopsis: authenticate support for apiary web framework. description: example: @@ -18,22 +18,25 @@ library exposed-modules: Web.Apiary.Authenticate - Web.Apiary.Authenticate.Explicit other-modules: Web.Apiary.Authenticate.Internal - build-depends: base >=4.6 && <4.8 - , apiary >=0.14 && <0.16 - , apiary-clientsession >=0.9 && <0.14 - , authenticate >=1.3 && <1.4 - , http-client >=0.3 && <0.4 - , http-client-tls >=0.2 && <0.3 - , data-default-class >=0.0 && <0.1 - , bytestring >=0.10 && <0.11 - , text >=1.1 && <1.2 - , resourcet >=1.1 && <1.2 - , http-types >=0.8 && <0.9 - , blaze-builder >=0.3 && <0.4 - , reflection >=1.4 && <1.6 - , binary >=0.7 && <0.8 + build-depends: base >=4.6 && <4.8 + , apiary >=0.16 && <0.17 + , apiary-clientsession >=0.16 && <0.17 + , authenticate >=1.3 && <1.4 + + , monad-control >=0.3 && <0.4 + + , http-client >=0.3 && <0.4 + , http-client-tls >=0.2 && <0.3 + + , data-default-class >=0.0 && <0.1 + , bytestring >=0.10 && <0.11 + , text >=1.1 && <1.2 + , http-types >=0.8 && <0.9 + , binary >=0.7 && <0.8 + + , resourcet >=1.1 && <1.2 + , blaze-builder >=0.3 && <0.4 hs-source-dirs: src ghc-options: -O2 -Wall diff --git a/src/Web/Apiary/Authenticate.hs b/src/Web/Apiary/Authenticate.hs --- a/src/Web/Apiary/Authenticate.hs +++ b/src/Web/Apiary/Authenticate.hs @@ -1,12 +1,16 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} -module Web.Apiary.Authenticate ( - E.AuthConfig(..), E.Provider(..) - , E.OpenId_(..), E.OpenId - , HasAuth - , withAuth, withAuthWith +module Web.Apiary.Authenticate + ( I.Auth + , I.AuthConfig(..), I.Provider(..) + , I.OpenId_(..), I.OpenId + -- * initializer + , initAuth, initAuthWith, initAuthWithManager + -- * handler , authHandler -- * filter , authorized @@ -14,49 +18,62 @@ , authLogout -- ** getter , authConfig, authProviders, authRoutes - -- * reexport - , module Data.Default.Class ) where import Web.Apiary -import qualified Web.Apiary.Authenticate.Explicit as E +import qualified Web.Apiary.Authenticate.Internal as I import qualified Network.HTTP.Client as Client import Network.HTTP.Client.TLS(tlsManagerSettings) import Web.Apiary.ClientSession +import Control.Monad +import Control.Monad.Trans.Control -import Data.Reflection -import Data.Default.Class -import Data.Apiary.SList import qualified Data.Text as T import qualified Data.ByteString as S -type HasAuth = Given E.Auth +import Data.Apiary.Proxy +import Data.Apiary.Extension +import Data.Apiary.Extension.Internal -withAuth :: HasSession => E.AuthConfig -> (HasAuth => IO a) -> IO a -withAuth = withAuthWith tlsManagerSettings +initAuthWithManager :: (Has Session exts, MonadBaseControl IO m) + => Client.Manager -> I.AuthConfig + -> Initializer exts m (I.Auth ': exts) +initAuthWithManager mgr conf = Initializer $ \e -> do + I.authWith mgr conf $ \a -> return $ addExtension a e -withAuthWith :: HasSession => Client.ManagerSettings - -> E.AuthConfig -> (HasAuth => IO a) -> IO a -withAuthWith ms ac m = E.withAuthWith given ms ac (\a -> give a m) +initAuthWith :: (Has Session exts, MonadBaseControl IO m) + => Client.ManagerSettings -> I.AuthConfig + -> Initializer exts m (I.Auth ': exts) +initAuthWith ms conf = Initializer $ \e -> do + control $ \run -> Client.withManager ms $ \mgr -> + I.authWith mgr conf $ \a -> run . return $ addExtension a e +initAuth :: (Has Session exts, MonadBaseControl IO m) + => I.AuthConfig -> Initializer exts m (I.Auth ': exts) +initAuth = initAuthWith tlsManagerSettings + -- | default auth handlers. since 0.8.0.0. -authHandler :: (Functor m, Monad m, Functor n, MonadIO n, HasAuth) => ApiaryT c n m () -authHandler = E.authHandler given +authHandler :: (Monad m, MonadIO actM, Has I.Auth exts, Has Session exts) + => ApiaryT exts prms actM m () +authHandler = apiaryExt (Proxy :: Proxy I.Auth) >>= I.authHandler -- | filter which check whether logged in or not, and get id. since 0.7.0.0. -authorized :: HasAuth => Apiary (Snoc as E.OpenId) a -> Apiary as a -authorized = E.authorized given +authorized :: (Has I.Auth exts, MonadIO actM, Has Session exts) + => ApiaryT exts (I.OpenId ': prms) actM m () -> ApiaryT exts prms actM m () +authorized m = do + a <- apiaryExt (Proxy :: Proxy I.Auth) + I.authorized a m -- | delete session. since 0.7.0.0. -authLogout :: (Monad m, HasAuth) => ActionT m () -authLogout = E.authLogout given +authLogout :: (Monad m, Has I.Auth exts) => ActionT exts m () +authLogout = getExt (Proxy :: Proxy I.Auth) >>= I.authLogout -authConfig :: HasAuth => E.AuthConfig -authConfig = E.authConfig given +authConfig :: (Has I.Auth exts, Monad m) => ActionT exts m I.AuthConfig +authConfig = I.config `liftM` getExt (Proxy :: Proxy I.Auth) -authProviders :: HasAuth => [(T.Text, E.Provider)] -authProviders = E.authProviders given +authProviders :: (Has I.Auth exts, Monad m) => ActionT exts m [(T.Text, I.Provider)] +authProviders = I.authProviders `liftM` getExt (Proxy :: Proxy I.Auth) -- | get authenticate routes: (title, route). since 0.7.0.0. -authRoutes :: HasAuth => [(T.Text, S.ByteString)] -authRoutes = E.authRoutes given +authRoutes :: (Has I.Auth exts, Monad m) => ActionT exts m [(T.Text, S.ByteString)] +authRoutes = I.authRoutes `liftM` getExt (Proxy :: Proxy I.Auth) diff --git a/src/Web/Apiary/Authenticate/Explicit.hs b/src/Web/Apiary/Authenticate/Explicit.hs deleted file mode 100644 --- a/src/Web/Apiary/Authenticate/Explicit.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Web.Apiary.Authenticate.Explicit ( - AuthConfig(..), Provider(..) - , Auth - , OpenId_(..), OpenId - , withAuth, withAuthWith - , authHandler - -- * filter - , authorized - -- * action - , authLogout - -- ** getter - , authConfig, authProviders, authRoutes - -- * reexport - , module Data.Default.Class - ) where - -import Web.Apiary.Authenticate.Internal -import Data.Default.Class diff --git a/src/Web/Apiary/Authenticate/Internal.hs b/src/Web/Apiary/Authenticate/Internal.hs --- a/src/Web/Apiary/Authenticate/Internal.hs +++ b/src/Web/Apiary/Authenticate/Internal.hs @@ -1,9 +1,12 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} module Web.Apiary.Authenticate.Internal where @@ -13,13 +16,12 @@ import Control.Monad.Trans.Resource import Control.Monad.Apiary.Filter.Internal -import Network.HTTP.Client.TLS(tlsManagerSettings) import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Client as Client import Web.Authenticate.OpenId -import Web.Apiary hiding(Default(..)) -import Web.Apiary.ClientSession.Explicit +import Web.Apiary +import Web.Apiary.ClientSession import qualified Web.Apiary.Wai as Wai import Data.Binary @@ -28,6 +30,8 @@ import Data.List import Data.Apiary.SList import Data.Apiary.Proxy +import Data.Apiary.Extension +import Data.Default.Class import Blaze.ByteString.Builder import qualified Data.ByteString.Char8 as S @@ -37,15 +41,16 @@ data AuthConfig = AuthConfig - { authSessionName :: S.ByteString - , authSuccessPage :: S.ByteString - , authUrl :: T.Text + { authSessionName :: S.ByteString + , authSuccessPage :: S.ByteString + , authSessionConfig :: SessionConfig + , authUrl :: T.Text - , authPrefix :: [T.Text] - , authReturnToPath :: [T.Text] - , authLogoutPath :: [T.Text] + , authPrefix :: [T.Text] + , authReturnToPath :: [T.Text] + , authLogoutPath :: [T.Text] - , providers :: [(T.Text, Provider)] + , providers :: [(T.Text, Provider)] } data Provider = Provider @@ -55,32 +60,29 @@ } instance Default AuthConfig where - def = AuthConfig "_ID" "/" "http://localhost:3000" ["auth"] ["return_to"] ["logout"] $ + 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 - , authSession :: Session + { manager :: Client.Manager + , config :: AuthConfig } -withAuth :: Session -> AuthConfig -> (Auth -> IO a) -> IO a -withAuth sess = withAuthWith sess tlsManagerSettings - -withAuthWith :: Session -> Client.ManagerSettings - -> AuthConfig -> (Auth -> IO a) -> IO a -withAuthWith sess s conf m = Client.withManager s $ \mgr -> - m (Auth mgr conf sess) +authWith :: MonadBaseControl IO m + => Client.Manager + -> AuthConfig -> (Auth -> m a) -> m a +authWith mgr conf m = m (Auth mgr conf) -authHandler :: (Functor m, Monad m, Functor n, MonadIO n) => Auth -> ApiaryT c n m () +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 (\_ r -> if p `isPrefixOf` Wai.pathInfo r then Just SNil else Nothing) retH = pfxPath (authPrefix config ++ authReturnToPath config) . method GET . action $ - returnAction authSession manager (authSessionName config) (authSuccessPage config) + returnAction (authSessionConfig config) manager (authSessionName config) (authSuccessPage config) go name Provider{..} = pfxPath (authPrefix config ++ [name]) . method GET . action $ authAction manager providerUrl returnTo realm parameters @@ -88,8 +90,9 @@ returnTo = T.decodeUtf8 $ T.encodeUtf8 (authUrl config) `S.append` toByteString (HTTP.encodePathSegments (authPrefix config ++ authReturnToPath config)) -authorized :: Auth -> Apiary (Snoc as OpenId) a -> Apiary as a -authorized Auth{..} = session authSession (authSessionName config) (pOne (Proxy :: Proxy OpenId)) +authorized :: (MonadIO actM, Has Session exts) + => Auth -> ApiaryT exts (OpenId ': prms) actM m () -> ApiaryT exts prms actM m () +authorized Auth{..} = session (authSessionName config) (pOne (Proxy :: Proxy OpenId)) authConfig :: Auth -> AuthConfig authConfig = config @@ -102,11 +105,11 @@ map (\(k,_) -> (k, toByteString . HTTP.encodePathSegments $ authPrefix (config auth) ++ [k])) $ providers (config auth) -authLogout :: Monad m => Auth -> ActionT m () +authLogout :: Monad m => Auth -> ActionT exts m () authLogout auth = deleteCookie (authSessionName $ config auth) authAction :: MonadIO m => Client.Manager -> T.Text -> T.Text - -> Maybe T.Text -> [(T.Text, T.Text)] -> ActionT m () + -> Maybe T.Text -> [(T.Text, T.Text)] -> ActionT exts m () authAction mgr uri returnTo realm param = do fw <- liftIO . runResourceT $ getForwardUrl uri returnTo realm param mgr redirect $ T.encodeUtf8 fw @@ -127,6 +130,7 @@ 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 @@ -136,12 +140,13 @@ (oirParams r) (identifier <$> oirClaimed r) -returnAction :: (Functor m, MonadIO m) - => Session -> Client.Manager -> S.ByteString -> S.ByteString -> ActionT m () -returnAction sess mgr key to = do +returnAction :: (MonadIO m, Has Session exts) + => SessionConfig -> Client.Manager + -> S.ByteString -> S.ByteString -> ActionT exts m () +returnAction sc mgr key to = do q <- Wai.queryString <$> getRequest r <- liftIO . runResourceT $ authenticateClaimed (mapMaybe queryElem q) mgr - setSession sess key . L.toStrict $ encode (toOpenId r) + setSessionWith sc key . L.toStrict $ encode (toOpenId r) redirect to where queryElem (_, Nothing) = Nothing