packages feed

apiary-authenticate (empty) → 0.7.0.0

raw patch · 5 files changed

+212/−0 lines, 5 filesdep +apiarydep +apiary-clientsessiondep +authenticatesetup-changed

Dependencies added: apiary, apiary-clientsession, authenticate, base, blaze-builder, bytestring, data-default-class, http-client, http-client-tls, http-types, monad-control, resourcet, text, wai

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ apiary-authenticate.cabal view
@@ -0,0 +1,43 @@+name:                apiary-authenticate+version:             0.7.0.0+synopsis:            authenticate support for apiary web framework.+description:+  example: <https://github.com/philopon/apiary/blob/master/examples/auth.hs>+license:             MIT+license-file:        LICENSE+author:              HirotomoMoriwaki<philopon.dependence@gmail.com>+maintainer:          HirotomoMoriwaki<philopon.dependence@gmail.com>+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
+ src/Web/Apiary/Authenticate.hs view
@@ -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
+ src/Web/Apiary/Authenticate/Internal.hs view
@@ -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)