wai-middleware-auth (empty) → 0.1.0.0
raw patch · 16 files changed
+1558/−0 lines, 16 filesdep +aesondep +basedep +base64-bytestringsetup-changed
Dependencies added: aeson, base, base64-bytestring, binary, blaze-builder, blaze-html, bytestring, case-insensitive, cereal, clientsession, cookie, exceptions, hoauth2, http-client, http-client-tls, http-conduit, http-reverse-proxy, http-types, optparse-simple, regex-posix, safe-exceptions, shakespeare, text, unix-compat, unordered-containers, vault, wai, wai-app-static, wai-extra, wai-middleware-auth, warp, yaml
Files
- CHANGELOG.md +4/−0
- LICENSE +21/−0
- README.md +67/−0
- Setup.hs +2/−0
- app/Main.hs +97/−0
- src/Network/Wai/Auth/AppRoot.hs +60/−0
- src/Network/Wai/Auth/ClientSession.hs +81/−0
- src/Network/Wai/Auth/Config.hs +109/−0
- src/Network/Wai/Auth/Executable.hs +96/−0
- src/Network/Wai/Auth/Tools.hs +44/−0
- src/Network/Wai/Middleware/Auth.hs +290/−0
- src/Network/Wai/Middleware/Auth/OAuth2.hs +96/−0
- src/Network/Wai/Middleware/Auth/OAuth2/Github.hs +133/−0
- src/Network/Wai/Middleware/Auth/OAuth2/Google.hs +123/−0
- src/Network/Wai/Middleware/Auth/Provider.hs +261/−0
- wai-middleware-auth.cabal +74/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.1.0.0+=======++* Initial implementation.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017 Alexey Kuleshevich++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.
+ README.md view
@@ -0,0 +1,67 @@+# wai-middleware-auth++Middleware that secures WAI application++## Installation++```shell+$ stack install wai-middleware-auth+```+OR+```shell+$ cabal install wai-middleware-auth+```++## wai-auth++Along with middleware this package ships with an executbale `wai-auth`, which+can function as a protected file server or a reverse proxy. Right from the box+it supports OAuth2 authentication as well as it's custom implementations for+Google and Github.++Configuration is done using a yaml config file. Here is a sample file that will+configure `wai-auth` to run a file server with google and github authentication+on `http://localhost:3000`:++```yaml+app_root: "_env:APPROOT:http://localhost:3000"+app_port: 3000+cookie_age: 3600+secret_key: "...+vwscbKR4DyPT"+file_server:+ root_folder: "/path/to/html/files"+ redirect_to_index: true+ add_trailing_slash: true+providers:+ github:+ client_id: "...94cc"+ client_secret: "...166f"+ app_name: "Dev App for wai-middleware-auth"+ email_white_list:+ - "^[a-zA-Z0-9._%+-]+@example.com$"+ google:+ client_id: "...qlj.apps.googleusercontent.com"+ client_secret: "...oxW"+ email_white_list:+ - "^[a-zA-Z0-9._%+-]+@example.com$"+```++Above configuration will also block access to users that don't have an email+with `example.com` domain. There is also a `secret_key` field which will be used+to encrypt the session cookie. In order to generate a new random key run this command:++```shell+$ echo $(wai-auth key --base64)+azuCFq0zEBkLSXhQrhliZzZD8Kblo...+```++Make sure you have proper callback/redirect urls registered with google/github+apps, eg: `http://localhost:3000/_auth_middleware/google/complete`.++After configuration file is ready, running application is very easy:++```shell+$ wai-auth --config-file=/path/to/config.yaml+Listening on port 3000+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Main where+import qualified Data.ByteString as S+-- import Data.ByteString.Base64 as B64+import Data.Monoid ((<>))+import Data.Serialize (put, runPut)+import Network.Wai.Auth.Executable+import Network.Wai.Handler.Warp (run)+import Network.Wai.Middleware.Auth+import Network.Wai.Middleware.Auth.OAuth2+import Network.Wai.Middleware.Auth.OAuth2.Github+import Network.Wai.Middleware.Auth.OAuth2.Google+import Options.Applicative.Simple+import Web.ClientSession++data BasicOptions+ = ConfigFile FilePath+ | KeyFile KeyOptions++basicSettingsParser :: String -> Parser BasicOptions+basicSettingsParser version =+ (ConfigFile <$>+ strOption+ (long "config-file" <> short 'c' <> metavar "CONFIG" <>+ help "File with configuration for the Auth application.") <*+ abortOption+ (InfoMsg version)+ (long "version" <> short 'v' <> help "Current version.") <*+ abortOption+ ShowHelpText+ (long "help" <> short 'h' <> help "Display this message.")) <|>+ (subparser+ (command+ "key"+ (info+ (KeyFile <$> keyOptionsParser)+ (progDesc+ ("Command for creating a secret key or converting one into base64 " +++ "form, which can then be directly used inside a config file.") <>+ fullDesc))))+++data KeyOptions = KeyOptions+ { keyInput :: FilePath+ , keyOutput :: FilePath+ , keyBase64 :: Bool+ }++keyOptionsParser :: Parser KeyOptions+keyOptionsParser =+ KeyOptions <$>+ strOption+ (long "input-file" <> short 'i' <> metavar "INPUT" <> value "" <>+ help "Read key from a file, instead of generating a new one.") <*>+ strOption+ (long "output-file" <> short 'o' <> metavar "OUTPUT" <> value "" <>+ help "Write key into a file, instead of stdout. File will be overwritten.") <*>+ switch+ (long "base64" <> short 'b' <>+ help "Produce a key in a base64 encoded form.") <*+ abortOption+ ShowHelpText+ (long "help" <> short 'h' <> help "Display this message.")+++main :: IO ()+main = do+ opts <-+ execParser+ (info+ (basicSettingsParser $(simpleVersion waiMiddlewareAuthVersion))+ (header "wai-auth - Authentication server" <>+ progDesc "Run a protected file server or reverse proxy." <>+ fullDesc))+ case opts of+ ConfigFile configFile -> do+ authConfig <- readAuthConfig configFile+ mkMain authConfig [githubParser, googleParser, oAuth2Parser] $ \port app -> do+ putStrLn $ "Listening on port " ++ show port+ run port app+ KeyFile (KeyOptions {..}) -> do+ let key2str =+ if keyBase64+ then encodeKey+ else (runPut . put)+ key <-+ key2str <$>+ if null keyInput+ then snd <$> randomKey+ else do+ keyContent <- S.readFile keyInput+ either error return (decodeKey keyContent <|> initKey keyContent)+ if null keyOutput+ then S.putStr key+ else S.writeFile keyOutput key
+ src/Network/Wai/Auth/AppRoot.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Wai.Auth.AppRoot+ ( smartAppRoot+ ) where++import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI, mk)+import qualified Data.HashMap.Lazy as HM+import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Network.HTTP.Types (Header)+import Network.Wai (Request, isSecure, requestHeaderHost,+ requestHeaders)+++-- | Determine approot by:+--+-- * Respect the Host header and isSecure property, together with the following de facto standards: x-forwarded-protocol, x-forwarded-ssl, x-url-scheme, x-forwarded-proto, front-end-https. (Note: this list may be updated at will in the future without doc updates.)+--+-- Normally trusting headers in this way is insecure, however in the case of approot, the worst that can happen is that the client will get an incorrect URL. Note that this does not work for some situations, e.g.:+--+-- * Reverse proxies not setting one of the above mentioned headers+--+-- * Applications hosted somewhere besides the root of the domain name+--+-- * Reverse proxies that modify the host header+--+-- @since 0.1.0.0+smartAppRoot :: Request -> T.Text+smartAppRoot req =+ let secure = isSecure req || any isSecureHeader (requestHeaders req)+ host =+ maybe "localhost" (decodeUtf8With lenientDecode) (requestHeaderHost req)+ in (if secure+ then "https://"+ else "http://") <>+ host++-- |+--+-- See: http://stackoverflow.com/a/16042648/369198+httpsHeaders :: HM.HashMap (CI ByteString) (CI ByteString)+httpsHeaders =+ HM.fromList+ [ ("X-Forwarded-Protocol", "https")+ , ("X-Forwarded-Ssl", "on")+ , ("X-Url-Scheme", "https")+ , ("X-Forwarded-Proto", "https")+ , ("Front-End-Https", "on")+ ]++isSecureHeader :: Header -> Bool+isSecureHeader (key, value) =+ case HM.lookup key httpsHeaders of+ Nothing -> False+ Just value' -> valueCI == value'+ where+ valueCI = mk value
+ src/Network/Wai/Auth/ClientSession.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+module Network.Wai.Auth.ClientSession+ ( loadCookieValue+ , saveCookieValue+ , Key+ , getDefaultKey+ ) where++import Blaze.ByteString.Builder (toByteString)+import Control.Monad (guard)+import Data.Binary (Binary, decodeOrFail, encode)+import qualified Data.ByteString as S+import qualified Data.ByteString.Base64.URL as B64+import qualified Data.ByteString.Lazy as L+import Data.Int (Int64)+import Data.Maybe (listToMaybe)+import Foreign.C.Types (CTime (..))+import GHC.Generics (Generic)+import Network.HTTP.Types (Header)+import Network.Wai (Request, requestHeaders)+import System.PosixCompat.Time (epochTime)+import Web.ClientSession (Key, decrypt, encryptIO,+ getDefaultKey)+import Web.Cookie (def, parseCookies, renderSetCookie,+ setCookieHttpOnly, setCookieMaxAge,+ setCookieName, setCookiePath,+ setCookieValue)++data Wrapper value = Wrapper+ { contained :: value+ , expires :: !Int64 -- ^ should really be EpochTime or CTime, but there's no Binary instance+ } deriving (Generic)+instance Binary value => Binary (Wrapper value)++loadCookieValue+ :: Binary value+ => Key+ -> S.ByteString -- ^ cookie name+ -> Request+ -> IO (Maybe value)+loadCookieValue key name req = do+ CTime now <- epochTime+ return $+ listToMaybe $ do+ (k, v) <- requestHeaders req+ guard $ k == "cookie"+ (name', v') <- parseCookies v+ guard $ name == name'+ Right v'' <- return $ B64.decode v'+ Just v''' <- return $ decrypt key v''+ Right (_, _, Wrapper res expi) <-+ return $ decodeOrFail $ L.fromStrict v'''+ guard $ expi >= fromIntegral now+ return res++saveCookieValue+ :: Binary value+ => Key+ -> S.ByteString -- ^ cookie name+ -> Int -- ^ age in seconds+ -> value+ -> IO Header+saveCookieValue key name age value = do+ CTime now <- epochTime+ value' <-+ encryptIO key $+ L.toStrict $+ encode+ Wrapper {contained = value, expires = fromIntegral now + fromIntegral age}+ return+ ( "Set-Cookie"+ , toByteString $+ renderSetCookie+ def+ { setCookieName = name+ , setCookieValue = B64.encode value'+ , setCookiePath = Just "/"+ , setCookieHttpOnly = True+ , setCookieMaxAge = Just $ fromIntegral age+ })
+ src/Network/Wai/Auth/Config.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Wai.Auth.Config+ ( AuthConfig(..)+ , SecretKey(..)+ , Service(..)+ , FileServer(..)+ , ReverseProxy(..)+ , encodeKey+ , decodeKey+ ) where++import Data.Aeson+import Data.Aeson.TH (defaultOptions, deriveJSON,+ fieldLabelModifier)+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Network.Wai.Auth.Tools (decodeKey, encodeKey,+ toLowerUnderscore)+import Web.ClientSession (Key)++-- | Configuration for a secret key that will be used to encrypt authenticated+-- user as client side cookie.+data SecretKey+ = SecretKeyFile FilePath -- ^ Path to a secret key file in binary form, if it+ -- is malformed or doesn't exist it will be+ -- (re)created. If empty "client_session_key.aes"+ -- name will be used+ | SecretKey Key -- ^ Serialized and base64 encoded form of a secret key. Use+ -- `encodeKey` to get a proper encoded form.+++-- | Configuration for reverse proxy application.+data FileServer = FileServer+ { fsRootFolder :: FilePath -- ^ Path to a folder containing files+ -- that will be served by this app.+ , fsRedirectToIndex :: Bool -- ^ Redirect to the actual index file, not+ -- leaving the URL containing the directory+ -- name+ , fsAddTrailingSlash :: Bool -- ^ Add a trailing slash to directory names+ }++-- | Configuration for reverse proxy application.+data ReverseProxy = ReverseProxy+ { rpHost :: T.Text -- ^ Hostname of the webserver+ , rpPort :: Int -- ^ Port of the webserver+ }++-- | Available services.+data Service = ServiceFiles FileServer+ | ServiceProxy ReverseProxy++-- | Configuration for @wai-auth@ executable and any other, that is created using+-- `Network.Wai.Auth.Executable.mkMain`+data AuthConfig = AuthConfig+ { configAppRoot :: Maybe T.Text -- ^ Root Url of the website, eg:+ -- http://example.com or+ -- https://example.com It will be used to+ -- perform redirects back from external+ -- authentication providers.+ , configAppPort :: Int -- ^ Port number. Default is 3000+ , configRequireTls :: Bool -- ^ Require requests come in over a secure+ -- connection (determined via headers). Will+ -- redirect to HTTPS if non-secure+ -- dedected. Default is @False@+ , configSkipAuth :: Bool -- ^ Turn off authentication middleware, useful for+ -- testing. Default is @False@+ , configCookieAge :: Int -- ^ Duration of the session in seconds. Default is+ -- one hour (3600 seconds).+ , configSecretKey :: SecretKey -- ^ Secret key. Default is "client_session_key.aes"+ , configService :: Service+ , configProviders :: Object+ }+++instance FromJSON AuthConfig where+ parseJSON =+ withObject "Auth Config Object" $ \obj -> do+ configAppRoot <- obj .:? "app_root"+ configAppPort <- obj .:? "app_port" .!= 3000+ configRequireTls <- (obj .:? "require_tls" .!= False)+ configSkipAuth <- obj .:? "skip_auth" .!= False+ configCookieAge <- obj .:? "cookie_age" .!= 3600+ mSecretKeyB64T <- obj .:? "secret_key"+ configSecretKey <-+ case mSecretKeyB64T of+ Just secretKeyB64T ->+ either fail (return . SecretKey) $ decodeKey (encodeUtf8 secretKeyB64T)+ Nothing -> SecretKeyFile <$> (obj .:? "secret_key_file" .!= "")+ mFileServer <- obj .:? "file_server"+ mReverseProxy <- obj .:? "reverse_proxy"+ let sErrMsg =+ "Either 'file_server' or 'reverse_proxy' is required, but not both."+ configService <-+ case (mFileServer, mReverseProxy) of+ (Just fileServer, Nothing) -> ServiceFiles <$> parseJSON fileServer+ (Nothing, Just reverseProxy) ->+ ServiceProxy <$> parseJSON reverseProxy+ (Just _, Just _) -> fail $ "Too many services. " ++ sErrMsg+ (Nothing, Nothing) -> fail $ "No service is supplied. " ++ sErrMsg+ configProviders <- obj .: "providers"+ return AuthConfig {..}++$(deriveJSON defaultOptions { fieldLabelModifier = toLowerUnderscore . drop 2} ''FileServer)++$(deriveJSON defaultOptions { fieldLabelModifier = toLowerUnderscore . drop 2} ''ReverseProxy)++
+ src/Network/Wai/Auth/Executable.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Network.Wai.Auth.Executable+ ( mkMain+ , readAuthConfig+ , serviceToApp+ , module Network.Wai.Auth.Config+ , Port+ ) where+import Data.Aeson (Result (..))+import Data.String (fromString)+import Data.Text.Encoding (encodeUtf8)+import Data.Yaml.Config (loadYamlSettings, useEnv)+import Network.HTTP.Client.TLS (getGlobalManager)+import Network.HTTP.ReverseProxy (ProxyDest (..),+ WaiProxyResponse (WPRProxyDest),+ defaultOnExc, waiProxyTo)+import Network.Wai (Application)+import Network.Wai.Application.Static (defaultFileServerSettings,+ ssAddTrailingSlash,+ ssRedirectToIndex,+ staticApp)+import Network.Wai.Auth.Config+import Network.Wai.Middleware.Auth+import Network.Wai.Middleware.Auth.Provider+import Network.Wai.Middleware.ForceSSL (forceSSL)+import Web.ClientSession (getKey)+++type Port = Int++-- | Create an `Application` from a `Service`+--+-- @since 0.1.0+serviceToApp :: Service -> IO Application+serviceToApp (ServiceFiles FileServer {..}) = do+ return $+ staticApp+ (defaultFileServerSettings $ fromString fsRootFolder)+ { ssRedirectToIndex = fsRedirectToIndex+ , ssAddTrailingSlash = fsAddTrailingSlash+ }+serviceToApp (ServiceProxy (ReverseProxy host port)) = do+ manager <- getGlobalManager+ return $+ waiProxyTo+ (const $ return $ WPRProxyDest $ ProxyDest (encodeUtf8 host) port)+ defaultOnExc+ manager+++-- | Read configuration from a yaml file with ability to use environment+-- variables. See "Data.Yaml.Config" module for details.+--+-- @since 0.1.0+readAuthConfig :: FilePath -> IO AuthConfig+readAuthConfig confFile = loadYamlSettings [confFile] [] useEnv+++-- | Construct a @main@ function.+--+-- @since 0.1.0+mkMain+ :: AuthConfig -- ^ Use `readAuthConfig` to read config from a file.+ -> [ProviderParser]+ -- ^ Parsers for supported providers. `ProviderParser` can be created with+ -- `Network.Wai.Middleware.Auth.Provider.mkProviderParser`.+ -> (Port -> Application -> IO ())+ -- ^ Application runner, for instance Warp's @run@ function.+ -> IO ()+mkMain AuthConfig {..} providerParsers run = do+ let !providers =+ case parseProviders configProviders providerParsers of+ Error errMsg -> error errMsg+ Success providers' -> providers'+ let authSettings =+ (case configSecretKey of+ SecretKey key -> setAuthKey $ return key+ SecretKeyFile "" -> id+ SecretKeyFile keyPath -> setAuthKey (getKey keyPath))+ . (case configAppRoot of+ Just appRoot -> setAuthAppRootStatic appRoot+ Nothing -> id)+ . setAuthProviders providers+ . setAuthSessionAge configCookieAge+ $ defaultAuthSettings+ authMiddleware <- mkAuthMiddleware authSettings+ app <- serviceToApp configService+ run configAppPort $+ (if configRequireTls+ then forceSSL+ else id)+ (if configSkipAuth+ then app+ else authMiddleware app)
+ src/Network/Wai/Auth/Tools.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE BangPatterns #-}+module Network.Wai.Auth.Tools+ ( encodeKey+ , decodeKey+ , toLowerUnderscore+ , getValidEmail+ ) where++import qualified Data.ByteString as S+import Data.ByteString.Base64 as B64+import Data.Char (isLower, toLower)+import Data.Foldable (foldr')+import Data.Maybe (listToMaybe)+import Data.Serialize (Get, get, put, runGet, runPut)+import Text.Regex.Posix ((=~))+import Web.ClientSession (Key)+++-- | Decode a `Key` that is in a base64 encoded serialized form+decodeKey :: S.ByteString -> Either String Key+decodeKey secretKeyB64 = B64.decode secretKeyB64 >>= runGet (get :: Get Key)+++-- | Serialize and base64 encode a secret `Key`+encodeKey :: Key -> S.ByteString+encodeKey = B64.encode . runPut . put+++-- | Prepend all but the first capital letter with underscores and convert all+-- of them to lower case.+toLowerUnderscore :: String -> String+toLowerUnderscore [] = []+toLowerUnderscore (x:xs) = toLower x : (foldr' toLowerWithUnder [] xs)+ where+ toLowerWithUnder !y !acc+ | isLower y = y : acc+ | otherwise = '_' : toLower y : acc+++-- | Check email list against a whitelist and pick first one that matches or+-- Nothing otherwise.+getValidEmail :: [S.ByteString] -> [S.ByteString] -> Maybe S.ByteString+getValidEmail whitelist emails =+ listToMaybe [e =~ w | e <- emails, w <- whitelist]
+ src/Network/Wai/Middleware/Auth.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Network.Wai.Middleware.Auth+ ( -- * Settings+ AuthSettings+ , defaultAuthSettings+ , setAuthKey+ , setAuthAppRootStatic+ , setAuthAppRootGeneric+ , setAuthSessionAge+ , setAuthPrefix+ , setAuthCookieName+ , setAuthProviders+ , setAuthProvidersTemplate+ -- * Middleware+ , mkAuthMiddleware+ -- * Helpers+ , smartAppRoot+ , waiMiddlewareAuthVersion+ , getAuthUser+ ) where++import Blaze.ByteString.Builder (fromByteString)+import Data.Binary (Binary)+import qualified Data.ByteString as S+import Data.ByteString.Builder (Builder)+import qualified Data.HashMap.Strict as HM+import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With,+ encodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.Vault.Lazy as Vault+import Data.Version (Version)+import Foreign.C.Types (CTime (..))+import GHC.Generics (Generic)+import Network.HTTP.Types (status200, status303,+ status404, status501)+import Network.Wai (Middleware, Request,+ pathInfo, rawPathInfo,+ rawQueryString,+ responseBuilder,+ responseLBS, vault)+import Network.Wai.Auth.AppRoot+import Network.Wai.Auth.ClientSession+import Network.Wai.Middleware.Auth.Provider+import qualified Paths_wai_middleware_auth as Paths+import System.IO.Unsafe (unsafePerformIO)+import System.PosixCompat.Time (epochTime)+import Text.Hamlet (Render)+++++-- | Settings for creating the Auth middleware.+--+-- To create a value, use 'defaultAuthSettings' and then various setter+-- functions.+--+-- @since 0.1.0+data AuthSettings = AuthSettings+ { asGetKey :: IO Key+ , asGetAppRoot :: Request -> IO T.Text+ , asSessionAge :: Int -- ^ default: 3600 seconds (1 hour)+ , asAuthPrefix :: T.Text -- ^ default: _auth_middleware+ , asStateKey :: S.ByteString -- ^ Cookie name, default: auth_state+ , asProviders :: Providers+ , asProvidersTemplate :: Maybe T.Text -> Render Provider -> Providers -> Builder+ }++-- | Default middleware settings. See various setters in order to change+-- available settings+--+-- @since 0.1.0+defaultAuthSettings :: AuthSettings+defaultAuthSettings =+ AuthSettings+ { asGetKey = getDefaultKey+ , asGetAppRoot = return <$> smartAppRoot+ , asSessionAge = 3600+ , asAuthPrefix = "_auth_middleware"+ , asStateKey = "auth_state"+ , asProviders = HM.empty+ , asProvidersTemplate = providersTemplate+ }+++-- | Set the function to get client session key for encrypting cookie data.+--+-- Default: 'getDefaultKey'+--+-- @since 0.1.0+setAuthKey :: IO Key -> AuthSettings -> AuthSettings+setAuthKey x as = as { asGetKey = x }++-- | Set the cookie name.+--+-- Default: "auth_state"+--+-- @since 0.1.0+setAuthCookieName :: S.ByteString -> AuthSettings -> AuthSettings+setAuthCookieName x as = as { asStateKey = x }+++-- | Set the cookie key.+--+-- Default: "auth_state"+--+-- @since 0.1.0+setAuthPrefix :: T.Text -> AuthSettings -> AuthSettings+setAuthPrefix x as = as { asAuthPrefix = x }+++-- | The application root for this application.+--+-- | Set the root for this Aplication. Required for external Authentication+-- providers to perform proper redirect.+--+-- Default: use the APPROOT environment variable.+--+-- @since 0.1.0+setAuthAppRootStatic :: T.Text -> AuthSettings -> AuthSettings+setAuthAppRootStatic = setAuthAppRootGeneric . const . return++-- | More generalized version of 'setAuthApprootStatic'.+--+-- @since 0.1.0+setAuthAppRootGeneric :: (Request -> IO T.Text) -> AuthSettings -> AuthSettings+setAuthAppRootGeneric x as = as { asGetAppRoot = x }++-- | Number of seconds to keep an authentication cookie active+--+-- Default: 3600+--+-- @since 0.1.0+setAuthSessionAge :: Int -> AuthSettings -> AuthSettings+setAuthSessionAge x as = as { asSessionAge = x }+++-- | Set Authentication providers to be used.+--+-- Default is empty.+--+-- @since 0.1.0+setAuthProviders :: Providers -> AuthSettings -> AuthSettings+setAuthProviders !ps as = as { asProviders = ps }+++-- | Set a custom template that will be rendered for a providers page+--+-- Default: `providersTemplate`+--+-- @since 0.1.0+setAuthProvidersTemplate :: (Maybe T.Text -> Render Provider -> Providers -> Builder)+ -> AuthSettings+ -> AuthSettings+setAuthProvidersTemplate t as = as { asProvidersTemplate = t }+++-- | Current state of the user.+data AuthState = AuthNeedRedirect !S.ByteString+ | AuthLoggedIn !AuthUser+ deriving (Generic, Show)++instance Binary AuthState+++-- | Creates an Authentication middleware that will make sure application is+-- protected, thus allowing access only to users that go through an+-- authentication process with one of the available providers. If more than one+-- provider is specified, user will be directed to a page were one can be chosen+-- from a list.+--+-- @since 0.1.0+mkAuthMiddleware :: AuthSettings -> IO Middleware+mkAuthMiddleware AuthSettings {..} = do+ secretKey <- asGetKey+ let saveAuthState = saveCookieValue secretKey asStateKey asSessionAge+ authRouteRender = mkRouteRender Nothing asAuthPrefix []+ -- Redirect to a list of providers if more than one is available, otherwise+ -- start login process with the only provider.+ let enforceLogin protectedPath req respond =+ case pathInfo req of+ (prefix:rest)+ | prefix == asAuthPrefix ->+ case rest of+ [] ->+ case HM.elems asProviders of+ [] ->+ respond $+ responseLBS+ status501+ []+ "No Authentication providers available."+ [soleProvider] ->+ let loginUrl =+ encodeUtf8 $ authRouteRender soleProvider []+ in respond $+ responseLBS+ status303+ [("Location", loginUrl)]+ "Redirecting to Login page"+ _ ->+ respond $+ responseBuilder status200 [] $+ asProvidersTemplate Nothing authRouteRender asProviders+ (providerName:pathSuffix)+ | Just provider <- HM.lookup providerName asProviders -> do+ appRoot <- asGetAppRoot req+ let onSuccess userIdentity = do+ CTime now <- epochTime+ cookie <-+ saveAuthState $+ AuthLoggedIn $+ AuthUser+ { authUserIdentity = userIdentity+ , authProviderName = encodeUtf8 $ getProviderName provider+ , authLoginTime = now+ }+ return $+ responseBuilder+ status303+ [("Location", protectedPath), cookie]+ (fromByteString "Redirecting to " <>+ fromByteString protectedPath)+ let onFailure status errMsg =+ return $+ responseBuilder status [] $+ asProvidersTemplate+ (Just $ decodeUtf8With lenientDecode errMsg)+ authRouteRender+ asProviders+ let providerUrlRenderer (ProviderUrl suffix) =+ mkRouteRender+ (Just appRoot)+ asAuthPrefix+ suffix+ provider+ respond =<<+ handleLogin+ provider+ req+ pathSuffix+ providerUrlRenderer+ onSuccess+ onFailure+ _ -> respond $ responseLBS status404 [] "Unknown URL"+ _ -> do+ cookie <-+ saveAuthState $+ AuthNeedRedirect (rawPathInfo req <> rawQueryString req)+ respond $+ responseBuilder+ status303+ [("Location", "/" <> encodeUtf8 asAuthPrefix), cookie]+ "Redirecting to Login Page"+ return $ \app req respond -> do+ authState <- loadCookieValue secretKey asStateKey req+ case authState of+ Just (AuthLoggedIn user) ->+ let req' = req {vault = Vault.insert userKey user $ vault req}+ in app req' respond+ Just (AuthNeedRedirect url) -> enforceLogin url req respond+ Nothing -> enforceLogin "/" req respond+++userKey :: Vault.Key AuthUser+userKey = unsafePerformIO Vault.newKey+{-# NOINLINE userKey #-}+++-- | Get the username for the current user.+--+-- If called on a @Request@ behind the middleware, should always return a+-- @Just@ value.+--+-- @since 0.1.0+getAuthUser :: Request -> Maybe AuthUser+getAuthUser = Vault.lookup userKey . vault+++-- | Current version+--+-- @since 0.1.0+waiMiddlewareAuthVersion :: Version+waiMiddlewareAuthVersion = Paths.version+
+ src/Network/Wai/Middleware/Auth/OAuth2.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+module Network.Wai.Middleware.Auth.OAuth2+ ( OAuth2(..)+ , oAuth2Parser+ ) where++import Data.Aeson.TH (defaultOptions,+ deriveJSON,+ fieldLabelModifier)+import qualified Data.ByteString.Lazy as SL+import Data.Monoid ((<>))+import Data.Proxy (Proxy (..))+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Network.HTTP.Client.TLS (getGlobalManager)+import Network.HTTP.Types (status303, status403,+ status404, status501)+import qualified Network.OAuth.OAuth2 as OA2+import Network.Wai (queryString, responseLBS)+import Network.Wai.Auth.Tools (toLowerUnderscore)+import Network.Wai.Middleware.Auth.Provider+++data OAuth2 = OAuth2+ { oa2ClientId :: T.Text+ , oa2ClientSecret :: T.Text+ , oa2AuthorizeEndpoint :: T.Text+ , oa2AccessTokenEndpoint :: T.Text+ , oa2Scope :: Maybe [T.Text]+ , oa2ProviderInfo :: ProviderInfo+ }+++-- | Aeson parser for `OAuth2` provider.+--+-- @since 0.1.0+oAuth2Parser :: ProviderParser+oAuth2Parser = mkProviderParser (Proxy :: Proxy OAuth2)+++instance AuthProvider OAuth2 where+ getProviderName _ = "oauth2"+ getProviderInfo = oa2ProviderInfo+ handleLogin oa2@OAuth2 {..} req suffix renderUrl onSuccess onFailure = do+ let oauth2 =+ OA2.OAuth2+ { oauthClientId = encodeUtf8 oa2ClientId+ , oauthClientSecret = encodeUtf8 oa2ClientSecret+ , oauthOAuthorizeEndpoint = encodeUtf8 oa2AuthorizeEndpoint+ , oauthAccessTokenEndpoint = encodeUtf8 oa2AccessTokenEndpoint+ , oauthCallback =+ Just $ encodeUtf8 $ renderUrl (ProviderUrl ["complete"]) []+ }+ case suffix of+ [] -> do+ let scope = (encodeUtf8 . T.intercalate ",") <$> oa2Scope+ let redirectUrl =+ OA2.appendQueryParam (OA2.authorizationUrl oauth2) $+ maybe [] ((: []) . ("scope", )) scope+ return $+ responseLBS+ status303+ [("Location", redirectUrl)]+ "Redirect to OAuth2 Authentication server"+ ["complete"] ->+ let params = queryString req+ in case lookup "code" params of+ Just (Just code) -> do+ man <- getGlobalManager+ eRes <- OA2.fetchAccessToken man oauth2 code+ case eRes of+ Left err -> onFailure status501 $ SL.toStrict err+ Right token -> onSuccess $ OA2.accessToken token+ _ ->+ case lookup "error" params of+ (Just (Just "access_denied")) ->+ onFailure+ status403+ "User rejected access to the application."+ (Just (Just error_code)) ->+ onFailure status501 $ "Received an error: " <> error_code+ (Just Nothing) ->+ onFailure status501 $+ "Unknown error connecting to " <>+ encodeUtf8 (getProviderName oa2)+ Nothing ->+ onFailure+ status404+ "Page not found. Please continue with login."+ _ -> onFailure status404 "Page not found. Please continue with login."+++$(deriveJSON defaultOptions { fieldLabelModifier = toLowerUnderscore . drop 3} ''OAuth2)
+ src/Network/Wai/Middleware/Auth/OAuth2/Github.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Network.Wai.Middleware.Auth.OAuth2.Github+ ( Github(..)+ , mkGithubProvider+ , githubParser+ ) where+import Control.Exception.Safe (catchAny)+import Data.Maybe (fromMaybe)+import Data.Aeson+import qualified Data.ByteString as S+import Data.Monoid ((<>))+import Data.Proxy (Proxy (..))+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Network.HTTP.Simple (getResponseBody,+ httpJSON, parseRequest,+ setRequestHeaders)+import Network.HTTP.Types+import Network.Wai.Auth.Tools (getValidEmail)+import Network.Wai.Middleware.Auth.OAuth2+import Network.Wai.Middleware.Auth.Provider+++-- | Create a github authentication provider+--+-- @since 0.1.0+mkGithubProvider+ :: T.Text -- ^ Name of the application as it is registered on github+ -> T.Text -- ^ @client_id@ from github+ -> T.Text -- ^ @client_secret@ from github+ -> [S.ByteString] -- ^ White list of posix regular expressions for emails+ -- attached to github account.+ -> Maybe ProviderInfo -- ^ Replacement for default info+ -> Github+mkGithubProvider appName clientId clientSecret emailWhiteList mProviderInfo =+ Github+ appName+ "https://api.github.com/user/emails"+ emailWhiteList+ OAuth2+ { oa2ClientId = clientId+ , oa2ClientSecret = clientSecret+ , oa2AuthorizeEndpoint = "https://github.com/login/oauth/authorize"+ , oa2AccessTokenEndpoint = "https://github.com/login/oauth/access_token"+ , oa2Scope = Just ["user:email"]+ , oa2ProviderInfo = fromMaybe defProviderInfo mProviderInfo+ }+ where+ defProviderInfo =+ ProviderInfo+ { providerTitle = "GitHub"+ , providerLogoUrl =+ "https://assets-cdn.github.com/images/modules/logos_page/Octocat.png"+ , providerDescr = "Use your GitHub account to access this page."+ }++-- | Aeson parser for `Github` provider.+--+-- @since 0.1.0+githubParser :: ProviderParser+githubParser = mkProviderParser (Proxy :: Proxy Github)+++-- | Github authentication provider+data Github = Github+ { githubAppName :: T.Text+ , githubAPIEmailEndpoint :: T.Text+ , githubEmailWhitelist :: [S.ByteString]+ , githubOAuth2 :: OAuth2+ }++instance FromJSON Github where+ parseJSON =+ withObject "Github Provider Object" $ \obj -> do+ appName <- obj .: "app_name"+ clientId <- obj .: "client_id"+ clientSecret <- obj .: "client_secret"+ emailWhiteList <- obj .:? "email_white_list" .!= []+ mProviderInfo <- obj .:? "provider_info"+ return $+ mkGithubProvider+ appName+ clientId+ clientSecret+ (map encodeUtf8 emailWhiteList)+ mProviderInfo++-- | Newtype wrapper for a github verified email+newtype GithubEmail = GithubEmail { githubEmail :: S.ByteString } deriving Show++instance FromJSON GithubEmail where+ parseJSON = withObject "Github Verified Email" $ \ obj -> do+ True <- obj .: "verified"+ email <- obj .: "email"+ return (GithubEmail $ encodeUtf8 email)+++-- | Makes an API call to github and retrieves all user's verified emails.+retrieveEmails :: T.Text -> T.Text -> S.ByteString -> IO [GithubEmail]+retrieveEmails appName emailApiEndpoint accessToken = do+ req <- parseRequest (T.unpack emailApiEndpoint)+ resp <- httpJSON $ setRequestHeaders headers req+ return $ getResponseBody resp+ where+ headers =+ [ ("Accept", "application/vnd.github.v3+json")+ , ("Authorization", "token " <> accessToken)+ , ("User-Agent", encodeUtf8 appName)+ ]+++instance AuthProvider Github where+ getProviderName _ = "github"+ getProviderInfo = getProviderInfo . githubOAuth2+ handleLogin Github {..} req suffix renderUrl onSuccess onFailure = do+ let onOAuth2Success accessToken = do+ catchAny+ (do emails <-+ map githubEmail <$>+ retrieveEmails+ githubAppName+ githubAPIEmailEndpoint+ accessToken+ let mEmail = getValidEmail githubEmailWhitelist emails+ case mEmail of+ Just email -> onSuccess email+ Nothing ->+ onFailure status403 $+ "No valid email was found with permission to access this resource. " <>+ "Please contact the administrator.")+ (\_err -> onFailure status501 "Issue communicating with github")+ handleLogin githubOAuth2 req suffix renderUrl onOAuth2Success onFailure
+ src/Network/Wai/Middleware/Auth/OAuth2/Google.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Network.Wai.Middleware.Auth.OAuth2.Google+ ( Google(..)+ , mkGoogleProvider+ , googleParser+ ) where+import Control.Exception.Safe (catchAny)+import Control.Monad (guard)+import Data.Aeson+import qualified Data.ByteString as S+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Proxy (Proxy (..))+import qualified Data.Text as T+import Data.Text.Encoding (encodeUtf8)+import Network.HTTP.Simple (getResponseBody,+ httpJSON, parseRequest,+ setRequestHeaders)+import Network.HTTP.Types+import Network.Wai.Auth.Tools (getValidEmail)+import Network.Wai.Middleware.Auth.OAuth2+import Network.Wai.Middleware.Auth.Provider+++-- | Create a google authentication provider+--+-- @since 0.1.0+mkGoogleProvider+ :: T.Text -- ^ @client_id@ from google+ -> T.Text -- ^ @client_secret@ from google+ -> [S.ByteString] -- ^ White list of posix regular expressions for emails+ -- attached to github account.+ -> Maybe ProviderInfo -- ^ Replacement for default info+ -> Google+mkGoogleProvider clientId clientSecret emailWhiteList mProviderInfo =+ Google+ "https://www.googleapis.com/oauth2/v3/userinfo"+ emailWhiteList+ OAuth2+ { oa2ClientId = clientId+ , oa2ClientSecret = clientSecret+ , oa2AuthorizeEndpoint = "https://accounts.google.com/o/oauth2/v2/auth"+ , oa2AccessTokenEndpoint = "https://www.googleapis.com/oauth2/v4/token"+ , oa2Scope = Just ["https://www.googleapis.com/auth/userinfo.email"]+ , oa2ProviderInfo = fromMaybe defProviderInfo mProviderInfo+ }+ where+ defProviderInfo =+ ProviderInfo+ { providerTitle = "Google"+ , providerLogoUrl =+ "https://upload.wikimedia.org/wikipedia/commons/thumb/5/53/Google_%22G%22_Logo.svg/200px-Google_%22G%22_Logo.svg.png"+ , providerDescr = "Use your Google account to access this page."+ }++-- | Aeson parser for `Google` provider.+--+-- @since 0.1.0+googleParser :: ProviderParser+googleParser = mkProviderParser (Proxy :: Proxy Google)+++data Google = Google+ { googleAPIEmailEndpoint :: T.Text+ , googleEmailWhitelist :: [S.ByteString]+ , googleOAuth2 :: OAuth2+ }++instance FromJSON Google where+ parseJSON =+ withObject "Google Provider Object" $ \obj -> do+ clientId <- obj .: "client_id"+ clientSecret <- obj .: "client_secret"+ emailWhiteList <- obj .:? "email_white_list" .!= []+ mProviderInfo <- obj .:? "provider_info"+ return $+ mkGoogleProvider+ clientId+ clientSecret+ (map encodeUtf8 emailWhiteList)+ mProviderInfo+++newtype GoogleEmail = GoogleEmail { googleEmail :: S.ByteString } deriving Show++instance FromJSON GoogleEmail where+ parseJSON = withObject "Google Verified Email" $ \ obj -> do+ verified <- obj .: "email_verified"+ guard verified+ email <- obj .: "email"+ return (GoogleEmail $ encodeUtf8 email)++++-- | Makes a call to google API and retrieves user's main email.+retrieveEmail :: T.Text -> S.ByteString -> IO GoogleEmail+retrieveEmail emailApiEndpoint accessToken = do+ req <- parseRequest (T.unpack emailApiEndpoint)+ resp <- httpJSON $ setRequestHeaders headers req+ return $ getResponseBody resp+ where+ headers = [("Authorization", "Bearer " <> accessToken)]+++instance AuthProvider Google where+ getProviderName _ = "google"+ getProviderInfo = getProviderInfo . googleOAuth2+ handleLogin Google {..} req suffix renderUrl onSuccess onFailure = do+ let onOAuth2Success accessToken = do+ catchAny+ (do email <-+ googleEmail <$>+ retrieveEmail googleAPIEmailEndpoint accessToken+ let mEmail = getValidEmail googleEmailWhitelist [email]+ case mEmail of+ Just email' -> onSuccess email'+ Nothing ->+ onFailure+ status403+ "No valid email with permission to access was found.") $ \_err ->+ onFailure status501 "Issue communicating with google."+ handleLogin googleOAuth2 req suffix renderUrl onOAuth2Success onFailure
+ src/Network/Wai/Middleware/Auth/Provider.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+module Network.Wai.Middleware.Auth.Provider+ ( AuthProvider(..)+ -- * Provider+ , Provider(..)+ , ProviderUrl(..)+ , ProviderInfo(..)+ , Providers+ -- * Provider Parsing+ , ProviderParser+ , mkProviderParser+ , parseProviders+ -- * User+ , AuthUser(..)+ , UserIdentity+ -- * Template+ , mkRouteRender+ , providersTemplate+ ) where++import Blaze.ByteString.Builder (toByteString)+import Control.Arrow (second)+import Data.Aeson (FromJSON (..), Object,+ Result (..), Value)+import Data.Aeson.Types (parseEither)++import Data.Aeson.TH (defaultOptions, deriveJSON,+ fieldLabelModifier)+import Data.Aeson.Types (Parser)+import Data.Binary (Binary)+import qualified Data.ByteString as S+import qualified Data.ByteString.Builder as B+import qualified Data.HashMap.Strict as HM+import Data.Int+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Proxy (Proxy)+import qualified Data.Text as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import GHC.Generics (Generic)+import Network.HTTP.Types (Status, renderQueryText)+import Network.Wai (Request, Response)+import Network.Wai.Auth.Tools (toLowerUnderscore)+import Text.Blaze.Html.Renderer.Utf8 (renderHtmlBuilder)+import Text.Hamlet (Render, hamlet)++-- | Core Authentication class, that allows for extensibility of the Auth+-- middleware created by `Network.Wai.Middleware.Auth.mkAuthMiddleware`. Most+-- important function is `handleLogin`, which implements the actual behavior of a+-- provider. It's function arguments in order:+--+-- * @`ap`@ - Current provider.+-- * @`Request`@ - Request made to the login page+-- * @[`T.Text`]@ - Url suffix, i.e. last part of the Url split by @\'/\'@ character,+-- for instance @["login", "complete"]@ suffix in the example below.+-- * @`Render` `ProviderUrl`@ -+-- Url renderer. It takes desired suffix as first argument and produces an+-- absolute Url renderer. It can further be used to generate provider urls,+-- for instance in Hamlet templates as+-- will result in+-- @"https:\/\/approot.com\/_auth_middleware\/providerName\/login\/complete?user=Hamlet"@+-- or generate Urls for callbacks.+--+-- @+-- \@?{(ProviderUrl ["login", "complete"], [("user", "Hamlet")])}+-- @+--+-- * @(`UserIdentity` -> `IO` `Response`)@ - Action to call on a successfull login.+-- * @(`Status` -> `S.ByteString` -> `IO` `Response`)@ - Should be called in case of+-- a failure with login process by supplying a+-- status and a short error message.+class AuthProvider ap where++ -- | Return a name for the provider. It will be used as a unique identifier+ -- for this provider. Argument should not be evaluated, as there are many+ -- places were `undefined` value is passed to this function.+ --+ -- @since 0.1.0+ getProviderName :: ap -> T.Text++ -- | Get info about the provider. It will be used in rendering the web page+ -- with a list of providers.+ --+ -- @since 0.1.0+ getProviderInfo :: ap -> ProviderInfo++ -- | Handle a login request in a custom manner. Can be used to render a login+ -- page with a form or redirect to some other authentication service like+ -- OpenID or OAuth2.+ --+ -- @since 0.1.0+ handleLogin+ :: ap+ -> Request+ -> [T.Text]+ -> Render ProviderUrl+ -> (UserIdentity -> IO Response)+ -> (Status -> S.ByteString -> IO Response)+ -> IO Response+++-- | Generic authentication provider wrapper.+data Provider where+ Provider :: AuthProvider p => p -> Provider+++instance AuthProvider Provider where++ getProviderName (Provider p) = getProviderName p++ getProviderInfo (Provider p) = getProviderInfo p++ handleLogin (Provider p) = handleLogin p+++-- | Collection of supported providers.+type Providers = HM.HashMap T.Text Provider++-- | Aeson parser for a provider with unique provider name (same as returned by+-- `getProviderName`)+type ProviderParser = (T.Text, Value -> Parser Provider)++-- | Data type for rendering Provider specific urls.+data ProviderUrl = ProviderUrl [T.Text]++-- | Provider information used for rendering a page with list of supported providers.+data ProviderInfo = ProviderInfo+ { providerTitle :: T.Text+ , providerLogoUrl :: T.Text+ , providerDescr :: T.Text+ } deriving (Show)+++-- | An arbitrary user identifer, eg. a username or an email address.+type UserIdentity = S.ByteString++-- | Representation of a user for a particular `Provider`.+data AuthUser = AuthUser+ { authUserIdentity :: !UserIdentity+ , authProviderName :: !S.ByteString+ , authLoginTime :: !Int64+ } deriving (Generic, Show)++instance Binary AuthUser++++-- | First argument is not evaluated and is only needed for restricting the type.+mkProviderParser :: forall ap . (FromJSON ap, AuthProvider ap) => Proxy ap -> ProviderParser+mkProviderParser _ =+ ( getProviderName nameProxyError+ , fmap Provider <$> (parseJSON :: Value -> Parser ap))+ where+ nameProxyError :: ap+ nameProxyError = error "AuthProvider.getProviderName should not evaluate it's argument."++-- | Parse configuration for providers from an `Object`.+parseProviders :: Object -> [ProviderParser] -> Result Providers+parseProviders unparsedProvidersHM providerParsers =+ if HM.null unrecognized+ then sequence $ HM.intersectionWith parseProvider unparsedProvidersHM parsersHM+ else Error $+ "Provider name(s) are not recognized: " +++ T.unpack (T.intercalate ", " $ HM.keys unrecognized)+ where+ parsersHM = HM.fromList providerParsers+ unrecognized = HM.difference unparsedProvidersHM parsersHM+ parseProvider v p = either Error Success $ parseEither p v++-- | Create a url renderer for a provider.+mkRouteRender :: Maybe T.Text -> T.Text -> [T.Text] -> Render Provider+mkRouteRender appRoot authPrefix authSuffix (Provider p) params =+ (T.intercalate "/" $ [root, authPrefix, getProviderName p] ++ authSuffix) <>+ decodeUtf8With+ lenientDecode+ (toByteString $ renderQueryText True (map (second Just) params))+ where+ root = fromMaybe "" appRoot+++$(deriveJSON defaultOptions { fieldLabelModifier = toLowerUnderscore . drop 8} ''ProviderInfo)+++-- | Template for the providers page+providersTemplate :: Maybe T.Text -- ^ Error message to display, if any.+ -> Render Provider -- ^ Renderer function for provider urls.+ -> Providers -- ^ List of available providers.+ -> B.Builder+providersTemplate merrMsg render providers =+ renderHtmlBuilder $ [hamlet|+$doctype 5+<html>+ <head>+ <title>WAI Auth Middleware - Authentication Providers.+ <link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap.min.css" integrity="sha384-BVYiiSIFeK1dGmJRAkycuHAHRg32OmUcww7on3RYdg4Va+PmSTsz/K68vbdEjh4u" crossorigin="anonymous">+ <link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap-theme.min.css" integrity="sha384-rHyoN1iRsVXV4nD0JutlnGaslCJuC7uwjduW9SVrLvRYooPp2bWYgmgJQIXwl/Sp" crossorigin="anonymous">+ <script src="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/js/bootstrap.min.js" integrity="sha384-Tc5IQib027qvyjSMfHjOMaLkfuWVxZxUPnCJA7l2mCWNIpG9mGCD8wGNIcPD7Txa" crossorigin="anonymous">+ <style>+ .provider-logo {+ max-height: 64px;+ max-width: 64px;+ padding: 5px;+ margin: auto;+ position: absolute;+ top: 0;+ bottom: 0;+ left: 0;+ right: 0;+ }+ .media-container {+ width: 600px;+ position: absolute;+ top: 100px;+ bottom: 0;+ left: 0;+ right: 0;+ margin: auto;+ }+ .provider.media {+ border: 1px solid #e1e1e8;+ padding: 5px;+ height: 82px;+ text-overflow: ellipsis;+ margin-top: 5px;+ }+ .provider.media:hover {+ background-color: #f5f5f5;+ border: 1px solid #337ab7;+ }+ .provider .media-left {+ height: 70px;+ width: 0px;+ padding-right: 70px;+ position: relative;+ }+ a:hover {+ text-decoration: none;+ }+ <body>+ <div .media-container>+ <h3>Select one of available authentication methods:+ $maybe errMsg <- merrMsg+ <div .alert .alert-danger role="alert">+ #{errMsg}+ $forall provider <- providers+ $with info <- getProviderInfo provider+ <div .media.provider>+ <a href=@{provider}>+ <div .media-left .container>+ <img .provider-logo src=#{providerLogoUrl info}>+ <div .media-body>+ <h3 .media-heading>+ #{providerTitle info}+ #{providerDescr info}+|] render
+ wai-middleware-auth.cabal view
@@ -0,0 +1,74 @@+name: wai-middleware-auth+version: 0.1.0.0+synopsis: Authentication middleware that secures WAI application+description: See README+license: MIT+license-file: LICENSE+author: Alexey Kuleshevich+maintainer: alexey@fpcomplete.com+category: Web+build-type: Simple+extra-doc-files: README.md CHANGELOG.md+cabal-version: >=1.10++library+ exposed-modules: Network.Wai.Middleware.Auth+ Network.Wai.Middleware.Auth.OAuth2+ Network.Wai.Middleware.Auth.OAuth2.Github+ Network.Wai.Middleware.Auth.OAuth2.Google+ Network.Wai.Middleware.Auth.Provider+ Network.Wai.Auth.Executable+ other-modules: Paths_wai_middleware_auth+ Network.Wai.Auth.AppRoot+ Network.Wai.Auth.Config+ Network.Wai.Auth.ClientSession+ Network.Wai.Auth.Tools+ build-depends: aeson+ , base >= 4.7 && < 5+ , base64-bytestring+ , binary+ , blaze-builder+ , blaze-html+ , bytestring+ , case-insensitive+ , cereal+ , clientsession+ , cookie+ , exceptions+ , hoauth2+ , http-client+ , http-client-tls+ , http-conduit+ , http-reverse-proxy+ , http-types+ , regex-posix+ , safe-exceptions+ , shakespeare+ , text+ , unix-compat+ , unordered-containers+ , vault+ , wai >= 3.0 && < 4+ , wai-app-static+ , wai-extra >= 3.0.7+ , yaml+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++executable wai-auth+ default-language: Haskell2010+ hs-source-dirs: app+ main-is: Main.hs+ build-depends: base+ , bytestring+ , cereal+ , clientsession+ , optparse-simple+ , wai-middleware-auth+ , warp+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N++source-repository head+ type: git+ location: https://github.com/fpco/wai-middleware-auth