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: 1.1.0 +version: 1.2.0 synopsis: authenticate support for apiary web framework. description: example: @@ -20,20 +20,21 @@ exposed-modules: Web.Apiary.Authenticate other-modules: Web.Apiary.Authenticate.Internal build-depends: base >=4.6 && <4.8 - , apiary >=1.1 && <1.2 - , apiary-clientsession >=1.1 && <1.2 + , apiary >=1.2 && <1.3 + , apiary-session >=1.2 && <1.3 , authenticate >=1.3.2.10 && <1.4 + , wai >=3.0 && <3.1 , monad-control >=0.3 && <0.4 - , http-client >=0.3 && <0.4 + , http-client >=0.3 && <0.5 , http-client-tls >=0.2 && <0.3 , data-default-class >=0.0 && <0.1 , bytestring >=0.10 && <0.11 + , cereal >=0.4 && <0.5 , text >=1.1 && <1.3 , http-types >=0.8 && <0.9 - , binary >=0.7 && <0.8 , resourcet >=1.1 && <1.2 , blaze-builder >=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 @@ -1,22 +1,22 @@ -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE DataKinds #-} module Web.Apiary.Authenticate ( I.Auth , I.AuthConfig(..), I.Provider(..) - , I.OpenId_(..), I.OpenId + , I.OpenId_(..), I.OpenId, pOpenId -- * initializer , initAuth, initAuthWith, initAuthWithManager -- * handler , authHandler -- * filter - , authorized + , authorized, authorized' -- * action - , authLogout + , I.authLogout -- ** getter , authConfig, authProviders, authRoutes ) where @@ -25,47 +25,51 @@ 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 Web.Apiary.Session 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.Compat import Data.Apiary.Extension +import qualified Data.Apiary.Dict as Dict -initAuthWithManager :: (Has Session exts, MonadBaseControl IO m) +pOpenId :: Proxy I.OpenId +pOpenId = Proxy + +initAuthWithManager :: (Has (Session I.OpenId m) exts, MonadBaseControl IO m) => Client.Manager -> I.AuthConfig -> Initializer m exts (I.Auth ': exts) initAuthWithManager mgr conf = initializer' $ return (I.Auth mgr conf) -initAuthWith :: (Has Session exts, MonadBaseControl IO m) +initAuthWith :: (Has (Session I.OpenId m) exts, MonadBaseControl IO m) => Client.ManagerSettings -> I.AuthConfig -> Initializer m exts (I.Auth ': exts) initAuthWith ms conf = initializerBracket' $ \m -> control $ \run -> Client.withManager ms (\mgr -> run . m $ I.Auth mgr conf) -initAuth :: (Has Session exts, MonadBaseControl IO m) +initAuth :: (Has (Session I.OpenId m) exts, MonadBaseControl IO m) => I.AuthConfig -> Initializer m exts (I.Auth ': exts) initAuth = initAuthWith tlsManagerSettings -- | default auth handlers. since 0.8.0.0. -authHandler :: (Monad m, MonadIO actM, Has I.Auth exts, Has Session exts) +authHandler :: (Monad m, MonadIO actM, Has I.Auth exts, Has (Session I.OpenId actM) exts) => ApiaryT exts prms actM m () -authHandler = apiaryExt (Proxy :: Proxy I.Auth) >>= I.authHandler +authHandler = getExt (Proxy :: Proxy I.Auth) >>= I.authHandler --- | filter which check whether logged in or not, and get id. since 0.7.0.0. -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)) +authorized' :: (Has (Session I.OpenId actM) exts, KnownSymbol key, Monad actM, Dict.NotMember key kvs) + => proxy key + -> ApiaryT exts (key := I.OpenId ': kvs) actM m () + -> ApiaryT exts kvs actM m () +authorized' ky = session' ky (Proxy :: Proxy I.OpenId) --- | delete session. since 0.7.0.0. -authLogout :: (Monad m, Has I.Auth exts) => ActionT exts prms m () -authLogout = getExt (Proxy :: Proxy I.Auth) >>= I.authLogout +-- | filter which check whether logged in or not, and get id. since 0.7.0.0. +authorized :: (Has (Session I.OpenId actM) exts, Monad actM, Dict.NotMember "auth" kvs) + => ApiaryT exts ("auth" := I.OpenId ': kvs) actM m () + -> ApiaryT exts kvs actM m () +authorized = authorized' (Proxy :: Proxy "auth") authConfig :: (Has I.Auth exts, Monad m) => ActionT exts prms m I.AuthConfig authConfig = I.config `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 @@ -11,41 +11,38 @@ 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 Control.Applicative((<$>), (<*>)) +import Control.Monad.Trans.Resource(runResourceT) +import Control.Monad.Apiary(ApiaryT, action) +import Control.Monad.Apiary.Filter(function, method) +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.Authenticate.OpenId -import Web.Apiary -import Web.Apiary.ClientSession -import qualified Web.Apiary.Wai as Wai +import Web.Apiary(MonadIO(..)) +import Web.Apiary.Session(Session, deleteSession, setSession) -import Data.Binary as Binary -import Data.Apiary.Extension +import Data.Apiary.Extension(Has, Extension) +import Data.Apiary.Compat(Proxy(Proxy), Typeable) +import Data.Apiary.Method(Method(GET)) + +import qualified Data.Serialize as Serialize import Data.Data (Data) -import Data.Maybe -import Data.List -import Data.Apiary.Compat -import Data.Apiary.Param -import Data.Default.Class +import Data.Maybe(mapMaybe) +import Data.List(isPrefixOf) +import Data.Default.Class(Default(..)) -import Blaze.ByteString.Builder +import Blaze.ByteString.Builder(toByteString) 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 + { authSuccessPage :: S.ByteString , authUrl :: T.Text , authPrefix :: [T.Text] @@ -62,7 +59,7 @@ } instance Default AuthConfig where - def = AuthConfig "_ID" "/" def "http://localhost:3000" ["auth"] ["return_to"] ["logout"] $ + 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 []) ] @@ -73,14 +70,14 @@ } instance Extension Auth -authHandler :: (Monad m, MonadIO actM, Has Session exts) +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 = 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) + returnAction manager (authSuccessPage config) go name Provider{..} = pfxPath (authPrefix config ++ [name]) . method GET . action $ authAction manager providerUrl returnTo realm parameters @@ -99,48 +96,47 @@ 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) +-- | 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 $ getForwardUrl uri returnTo realm prm mgr + 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, Generic, Functor) -instance Binary (OpenId_ S.ByteString) + } deriving (Show, Read, Eq, Ord, Data, Typeable, Functor) -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 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 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 +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 :: OpenIdResponse -> OpenId +toOpenId :: OpenId.OpenIdResponse -> OpenId toOpenId r = OpenId_ - (identifier $ oirOpLocal r) - (oirParams r) - (identifier <$> oirClaimed r) + (OpenId.identifier $ OpenId.oirOpLocal r) + (OpenId.oirParams r) + (OpenId.identifier <$> OpenId.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 +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 $ authenticateClaimed (mapMaybe queryElem q) mgr - setSessionWith sc ky . L.toStrict $ encode (toOpenId r) + r <- liftIO . runResourceT $ OpenId.authenticateClaimed (mapMaybe queryElem q) mgr + setSession Proxy (toOpenId r) redirect to where queryElem (_, Nothing) = Nothing