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.17.0 +version: 1.0.0 synopsis: authenticate support for apiary web framework. description: example: @@ -20,8 +20,8 @@ exposed-modules: Web.Apiary.Authenticate other-modules: Web.Apiary.Authenticate.Internal build-depends: base >=4.6 && <4.8 - , apiary >=0.17 && <0.18 - , apiary-clientsession >=0.17 && <0.18 + , apiary >=1.0 && <1.1 + , apiary-clientsession >=1.0 && <1.1 , authenticate >=1.3.2.10 && <1.4 , monad-control >=0.3 && <0.4 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 @@ -3,6 +3,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} module Web.Apiary.Authenticate ( I.Auth @@ -27,11 +28,13 @@ import Web.Apiary.ClientSession import Control.Monad import Control.Monad.Trans.Control +import Control.Monad.Apiary +import Control.Monad.Apiary.Action import qualified Data.Text as T import qualified Data.ByteString as S -import Data.Apiary.Proxy +import Data.Apiary.Compat import Data.Apiary.Extension initAuthWithManager :: (Has Session exts, MonadBaseControl IO m) @@ -55,22 +58,21 @@ 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 :: (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 +authorized :: (Has Session exts, MonadIO actM, KnownSymbol k, NotMember k prms) + => proxy k -> ApiaryT exts (k := I.OpenId ': prms) actM m () + -> ApiaryT exts prms actM m () +authorized ky = session ky (pOne (Proxy :: Proxy I.OpenId)) -- | delete session. since 0.7.0.0. -authLogout :: (Monad m, Has I.Auth exts) => ActionT exts m () +authLogout :: (Monad m, Has I.Auth exts) => ActionT exts prms m () authLogout = getExt (Proxy :: Proxy I.Auth) >>= I.authLogout -authConfig :: (Has I.Auth exts, Monad m) => ActionT exts m I.AuthConfig +authConfig :: (Has I.Auth exts, Monad m) => ActionT exts prms m I.AuthConfig authConfig = I.config `liftM` getExt (Proxy :: Proxy I.Auth) -authProviders :: (Has I.Auth exts, Monad m) => ActionT exts m [(T.Text, I.Provider)] +authProviders :: (Has I.Auth exts, Monad m) => ActionT exts prms 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 :: (Has I.Auth exts, Monad m) => ActionT exts m [(T.Text, S.ByteString)] +authRoutes :: (Has I.Auth exts, Monad m) => ActionT exts prms m [(T.Text, S.ByteString)] authRoutes = I.authRoutes `liftM` getExt (Proxy :: Proxy I.Auth) 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 @@ -7,6 +7,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module Web.Apiary.Authenticate.Internal where @@ -14,7 +15,8 @@ import Control.Applicative import Control.Monad.Trans.Resource -import Control.Monad.Apiary.Filter.Internal +import Control.Monad.Apiary.Filter +import Control.Monad.Apiary.Action import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Client as Client @@ -24,12 +26,12 @@ import Web.Apiary.ClientSession import qualified Web.Apiary.Wai as Wai -import Data.Binary +import Data.Binary as Binary import Data.Data (Data) import Data.Maybe import Data.List -import Data.Apiary.SList -import Data.Apiary.Proxy +import Data.Apiary.Compat +import Data.Apiary.Param import Data.Default.Class import Blaze.ByteString.Builder @@ -73,7 +75,7 @@ => 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) + 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) @@ -84,10 +86,6 @@ returnTo = T.decodeUtf8 $ T.encodeUtf8 (authUrl config) `S.append` toByteString (HTTP.encodePathSegments (authPrefix config ++ authReturnToPath config)) -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 @@ -99,13 +97,13 @@ map (\(k,_) -> (k, toByteString . HTTP.encodePathSegments $ authPrefix (config auth) ++ [k])) $ providers (config auth) -authLogout :: Monad m => Auth -> ActionT exts m () +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 m () -authAction mgr uri returnTo realm param = do - fw <- liftIO . runResourceT $ getForwardUrl uri returnTo realm param mgr + -> 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_ @@ -116,7 +114,7 @@ instance Binary (OpenId_ S.ByteString) instance Binary (OpenId_ T.Text) where - get = fmap (fmap T.decodeUtf8) (get :: Get (OpenId_ S.ByteString)) + get = fmap (fmap T.decodeUtf8) (Binary.get :: Get (OpenId_ S.ByteString)) put g = put (fmap T.encodeUtf8 g) instance Query (OpenId_ T.Text) where @@ -136,11 +134,11 @@ returnAction :: (MonadIO m, Has Session exts) => SessionConfig -> Client.Manager - -> S.ByteString -> S.ByteString -> ActionT exts m () -returnAction sc mgr key to = do + -> 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 key . L.toStrict $ encode (toOpenId r) + setSessionWith sc ky . L.toStrict $ encode (toOpenId r) redirect to where queryElem (_, Nothing) = Nothing