diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Hirotomo Moriwaki + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/apiary-authenticate.cabal b/apiary-authenticate.cabal new file mode 100644 --- /dev/null +++ b/apiary-authenticate.cabal @@ -0,0 +1,43 @@ +name: apiary-authenticate +version: 0.7.0.0 +synopsis: authenticate support for apiary web framework. +description: + example: +license: MIT +license-file: LICENSE +author: HirotomoMoriwaki +maintainer: HirotomoMoriwaki +Homepage: https://github.com/philopon/apiary +Bug-reports: https://github.com/philopon/apiary/issues +copyright: (c) 2014 Hirotomo Moriwaki +category: Web +build-type: Simple +stability: experimental +-- extra-source-files: +cabal-version: >=1.10 + +library + exposed-modules: Web.Apiary.Authenticate + other-modules: Web.Apiary.Authenticate.Internal + build-depends: base >=4.6 && <4.8 + , apiary >=0.7 && <0.8 + , apiary-clientsession >=0.7 && <0.8 + , 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 + , monad-control >=0.3 && <0.4 + + hs-source-dirs: src + ghc-options: -O2 -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: git://github.com/philopon/apiary.git diff --git a/src/Web/Apiary/Authenticate.hs b/src/Web/Apiary/Authenticate.hs new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/Authenticate.hs @@ -0,0 +1,16 @@ +module Web.Apiary.Authenticate ( + AuthConfig(..), Provider(..) + , HasAuth + , withAuth, withAuthWith + -- * 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 new file mode 100644 --- /dev/null +++ b/src/Web/Apiary/Authenticate/Internal.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE Rank2Types #-} + +module Web.Apiary.Authenticate.Internal where + +import Control.Monad.Trans.Control +import Control.Monad.Trans.Resource +import Control.Applicative + +import Data.Maybe +import Data.List +import Data.Default.Class +import qualified Data.ByteString.Char8 as S +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 Network.HTTP.Types as HTTP +import qualified Network.HTTP.Client as Client +import Network.HTTP.Client.TLS(tlsManagerSettings) +import Web.Authenticate.OpenId + +import Web.Apiary hiding(Default(..)) +import Data.Apiary.SList +import Control.Monad.Apiary.Filter.Internal +import Web.Apiary.ClientSession + +data AuthConfig = AuthConfig + { authSessionName :: S.ByteString + , authSuccessPage :: S.ByteString + , 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" "/" "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 + } + +type HasAuth = (?webApiaryAuthenticateAuth :: Auth, HasSession) + +withAuth :: HasSession => AuthConfig -> (HasAuth => Apiary c ()) -> Apiary c () +withAuth = withAuthWith tlsManagerSettings + +withAuthWith :: HasSession => Client.ManagerSettings -> AuthConfig + -> (HasAuth => Apiary c ()) -> Apiary c () +withAuthWith s conf m = withManager s $ \mgr -> do + let ?webApiaryAuthenticateAuth = Auth mgr conf + addAuthHandler (Auth mgr conf) m + + +withManager :: MonadBaseControl IO m => Client.ManagerSettings -> (Client.Manager -> m a) -> m a +withManager conf f = control $ \run -> Client.withManager conf (\mgr -> run $ f mgr) + +addAuthHandler :: HasSession => Auth -> Apiary c () -> Apiary c () +addAuthHandler Auth{..} m = m >> retH >> mapM_ (uncurry go) (providers config) + where + 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) + + go name Provider{..} = pfxPath (authPrefix config ++ [name]) . stdMethod GET . action $ + authAction manager providerUrl returnTo realm parameters + + 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 ?webApiaryAuthenticateAuth) (pOne pByteString) + +-- | get auth config. since 0.7.0.0. +authConfig :: HasAuth => Action AuthConfig +authConfig = return (config ?webApiaryAuthenticateAuth) + +-- | get providers. since 0.7.0.0. +authProviders :: HasAuth => Action [(T.Text, Provider)] +authProviders = providers <$> authConfig + +-- | get authenticate routes: (title, route). since 0.7.0.0. +authRoutes :: HasAuth => Action [(T.Text, S.ByteString)] +authRoutes = do + conf <- authConfig + return . map (\(k,_) -> (k, toByteString . HTTP.encodePathSegments $ authPrefix conf ++ [k])) $ providers conf + +-- | delete session. since 0.7.0.0. +authLogout :: HasAuth => Action () +authLogout = do + conf <- authConfig + deleteCookie (authSessionName conf) + +authAction :: Client.Manager -> T.Text -> T.Text + -> Maybe T.Text -> [(T.Text, T.Text)] -> Action () +authAction mgr uri returnTo realm param = do + fw <- liftIO . runResourceT $ getForwardUrl uri returnTo realm param mgr + redirect $ T.encodeUtf8 fw + +returnAction :: HasSession => Client.Manager -> S.ByteString -> S.ByteString -> Action () +returnAction mgr key to = do + q <- Wai.queryString <$> getRequest + r <- liftIO . runResourceT $ authenticateClaimed (mapMaybe queryElem q) mgr + setSession key (T.encodeUtf8 . identifier $ oirOpLocal r) + redirect to + where + queryElem (_, Nothing) = Nothing + queryElem (k, Just v) = Just (T.decodeUtf8 k, T.decodeUtf8 v)