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.8.0.0 +version: 0.9.0.0 synopsis: authenticate support for apiary web framework. description: example: @@ -18,21 +18,23 @@ 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.8 && <0.9 - , apiary-clientsession >=0.8 && <0.9 + , apiary >=0.9 && <0.10 + , apiary-clientsession >=0.9 && <0.10 , 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 - , wai >=2.1 && <2.2 , resourcet >=1.1 && <1.2 , http-types >=0.8 && <0.9 , blaze-builder >=0.3 && <0.4 , reflection >=1.4 && <1.5 + , binary >=0.7 && <0.8 + , tagged >=0.7 && <0.8 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,5 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} + module Web.Apiary.Authenticate ( - AuthConfig(..), Provider(..) + E.AuthConfig(..), E.Provider(..) + , E.OpenId_(..), E.OpenId , HasAuth , withAuth, withAuthWith , authHandler @@ -13,5 +18,45 @@ , module Data.Default.Class ) where -import Web.Apiary.Authenticate.Internal +import Web.Apiary +import qualified Web.Apiary.Authenticate.Explicit as E +import qualified Network.HTTP.Client as Client +import Network.HTTP.Client.TLS(tlsManagerSettings) +import Web.Apiary.ClientSession + +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 + +withAuth :: HasSession => E.AuthConfig -> (HasAuth => IO a) -> IO a +withAuth = withAuthWith tlsManagerSettings + +withAuthWith :: HasSession => Client.ManagerSettings + -> E.AuthConfig -> (HasAuth => IO a) -> IO a +withAuthWith ms ac m = E.withAuthWith given ms ac (\a -> give a m) + +-- | default auth handlers. since 0.8.0.0. +authHandler :: (Functor n, MonadIO n, HasAuth) => ApiaryT c n m () +authHandler = E.authHandler given + +-- | 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 + +-- | delete session. since 0.7.0.0. +authLogout :: (Monad m, HasAuth) => ActionT m () +authLogout = E.authLogout given + +authConfig :: HasAuth => E.AuthConfig +authConfig = E.authConfig given + +authProviders :: HasAuth => [(T.Text, E.Provider)] +authProviders = E.authProviders given + +-- | get authenticate routes: (title, route). since 0.7.0.0. +authRoutes :: HasAuth => [(T.Text, S.ByteString)] +authRoutes = E.authRoutes given diff --git a/src/Web/Apiary/Authenticate/Explicit.hs b/src/Web/Apiary/Authenticate/Explicit.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/Authenticate/Explicit.hs @@ -0,0 +1,18 @@ +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,26 +1,29 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ImplicitParams #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} module Web.Apiary.Authenticate.Internal where import Control.Monad.Trans.Resource import Control.Applicative +import GHC.Generics(Generic) +import Data.Binary +import Data.Data import Data.Maybe import Data.List import Data.Default.Class -import Data.Reflection +import Data.Proxy -- for ghc-7.6 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 import Blaze.ByteString.Builder -import qualified Network.Wai as Wai +import qualified Web.Apiary.Wai as Wai import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Client as Client import Network.HTTP.Client.TLS(tlsManagerSettings) @@ -29,7 +32,7 @@ import Web.Apiary hiding(Default(..)) import Data.Apiary.SList import Control.Monad.Apiary.Filter.Internal -import Web.Apiary.ClientSession +import Web.Apiary.ClientSession.Explicit data AuthConfig = AuthConfig { authSessionName :: S.ByteString @@ -56,29 +59,26 @@ ] data Auth = Auth - { manager :: Client.Manager - , config :: AuthConfig + { manager :: Client.Manager + , config :: AuthConfig + , authSession :: Session } -type HasAuth = (Given Auth, HasSession) - -withAuth :: HasSession => AuthConfig -> (HasAuth => IO a) -> IO a -withAuth = withAuthWith tlsManagerSettings +withAuth :: Session -> AuthConfig -> (Auth -> IO a) -> IO a +withAuth sess = withAuthWith sess tlsManagerSettings -withAuthWith :: HasSession => Client.ManagerSettings - -> AuthConfig -> (HasAuth => IO a) -> IO a -withAuthWith s conf m = Client.withManager s $ \mgr -> - give (Auth mgr conf) m +withAuthWith :: Session -> Client.ManagerSettings + -> AuthConfig -> (Auth -> IO a) -> IO a +withAuthWith sess s conf m = Client.withManager s $ \mgr -> + m (Auth mgr conf sess) --- | default auth handlers. since 0.8.0.0. -authHandler :: (Functor n, MonadIO n, HasAuth) => ApiaryT c n m () -authHandler = retH >> mapM_ (uncurry go) (providers config) +authHandler :: (Functor n, MonadIO n) => Auth -> ApiaryT c n m () +authHandler Auth{..} = retH >> mapM_ (uncurry go) (providers config) where - Auth{..} = given pfxPath p = function (\_ r -> if p `isPrefixOf` Wai.pathInfo r then Just SNil else Nothing) retH = pfxPath (authPrefix config ++ authReturnToPath config) . stdMethod GET . action $ - returnAction manager (authSessionName config) (authSuccessPage config) + returnAction authSession manager (authSessionName config) (authSuccessPage config) go name Provider{..} = pfxPath (authPrefix config ++ [name]) . stdMethod GET . action $ authAction manager providerUrl returnTo realm parameters @@ -86,30 +86,22 @@ returnTo = T.decodeUtf8 $ T.encodeUtf8 (authUrl config) `S.append` toByteString (HTTP.encodePathSegments (authPrefix config ++ authReturnToPath config)) - --- | filter which check whether logged in or not, and get id. since 0.7.0.0. -authorized :: HasAuth => Apiary (Snoc as S.ByteString) a -> Apiary as a -authorized = session (authSessionName $ config given) (pOne pByteString) +authorized :: Auth -> Apiary (Snoc as OpenId) a -> Apiary as a +authorized Auth{..} = session authSession (authSessionName config) (pOne (Proxy :: Proxy OpenId)) --- | get auth config. since 0.7.0.0. -authConfig :: (Monad m, HasAuth) => ActionT m AuthConfig -authConfig = return (config given) +authConfig :: Auth -> AuthConfig +authConfig = config --- | get providers. since 0.7.0.0. -authProviders :: (Monad m, HasAuth) => ActionT m [(T.Text, Provider)] -authProviders = providers <$> authConfig +authProviders :: Auth -> [(T.Text, Provider)] +authProviders = providers . config --- | get authenticate routes: (title, route). since 0.7.0.0. -authRoutes :: (Monad m, HasAuth) => ActionT m [(T.Text, S.ByteString)] -authRoutes = do - conf <- authConfig - return . map (\(k,_) -> (k, toByteString . HTTP.encodePathSegments $ authPrefix conf ++ [k])) $ providers conf +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 :: (Monad m, HasAuth) => ActionT m () -authLogout = do - conf <- authConfig - deleteCookie (authSessionName conf) +authLogout :: Monad m => Auth -> ActionT 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 () @@ -117,11 +109,36 @@ fw <- liftIO . runResourceT $ getForwardUrl uri returnTo realm param mgr redirect $ T.encodeUtf8 fw -returnAction :: (MonadIO m, HasSession) => Client.Manager -> S.ByteString -> S.ByteString -> ActionT m () -returnAction mgr key to = do +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) (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 + +type OpenId = OpenId_ T.Text + +toOpenId :: OpenIdResponse -> OpenId +toOpenId r = OpenId_ + (identifier $ oirOpLocal r) + (oirParams r) + (identifier <$> oirClaimed r) + +returnAction :: MonadIO m => Session -> Client.Manager -> S.ByteString -> S.ByteString -> ActionT m () +returnAction sess mgr key to = do q <- Wai.queryString <$> getRequest r <- liftIO . runResourceT $ authenticateClaimed (mapMaybe queryElem q) mgr - setSession key (T.encodeUtf8 . identifier $ oirOpLocal r) + setSession sess key . L.toStrict $ encode (toOpenId r) redirect to where queryElem (_, Nothing) = Nothing