diff --git a/test/ExampleApp.hs b/test/ExampleApp.hs deleted file mode 100644 --- a/test/ExampleApp.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module ExampleApp where - -import ClassyPrelude.Yesod -import qualified Data.Aeson as J -import qualified Data.Aeson.KeyMap as HM -import qualified Data.Text as T -import Database.Persist.Sql -import ExampleProviderOpts -import Yesod.Auth -import Yesod.Auth.OIDC -import Yesod.Core.Types (Logger) - -data App = App - { appLogger :: Logger - , appHost :: Text - , appConnPool :: ConnectionPool - , appHttpManager :: Manager - , appBrochClientId :: ClientId - } - - -share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -OidcConfig - clientId Text - issuer Text - Primary clientId issuer - deriving Show - -OidcDomain - domain Text - clientId Text - issuer Text - Primary domain - Foreign OidcConfig oidc_domain_oidc_config_fk clientId issuer - deriving Show - --- | Users in this example app come exclusively from OIDC --- Providers. Users are created automatically on successful --- authentication -User - -- | We specifically do not make the email unique per-user, in - -- accordance with the OIDC spec - email Email - - -- | The unique issuer + subject pair could be made null-able in an - -- app that also allows non-OIDC registrations - issuer Text - subject Text - - UniqueUser issuer subject - deriving Show -|] - -mkYesod "App" [parseRoutes| -/ HomeR GET -/auth AuthR Auth getAuth -/convenient-test-token CsrfTokenR GET -/protected/resource ProtectedResourceR GET -|] - -instance Yesod App where -instance YesodAuth App where - type AuthId App = Key User - loginDest _ = HomeR - logoutDest _ = HomeR - authPlugins _ = [ authOIDC ] - getAuthId = return . fromPathPiece . credsIdent - maybeAuthId = defaultMaybeAuthId - - -getHomeR :: Handler () -getHomeR = pure () - -getCsrfTokenR :: Handler Text -getCsrfTokenR = do - setCsrfCookie - reqToken <$> getRequest >>= \case - Nothing -> error "app unexpectedly started without session storage" - Just t -> pure t - -getProtectedResourceR :: Handler J.Value -getProtectedResourceR = do - uid <- requireAuthId - pure $ J.String $ tshow uid - - -instance YesodPersist App where - type YesodPersistBackend App = SqlBackend - - runDB :: SqlPersistT Handler a -> Handler a - runDB db = getsYesod appConnPool >>= runSqlPool db - - -addProvider :: - ( PersistStoreWrite (YesodPersistBackend (HandlerSite f)) - , YesodPersist (HandlerSite f) - , MonadHandler f - , BaseBackend (YesodPersistBackend (HandlerSite f)) ~ SqlBackend) - => OidcConfig -> [Text] -> f () -addProvider cfg domains = liftHandler . runDB $ do - insert_ cfg - insertMany_ $ flip map domains $ \domain -> - OidcDomain { oidcDomainDomain = domain - , oidcDomainClientId = oidcConfigClientId cfg - , oidcDomainIssuer = oidcConfigIssuer cfg - } - -instance HasHttpManager App where - getHttpManager = appHttpManager - -instance YesodAuthOIDC App where - getHttpManagerForOidc = Right <$> getsYesod appHttpManager - getProviderConfig loginHint = do - let domain = snd $ T.breakOnEnd "@" loginHint - mConfig <- liftHandler . runDB $ get $ OidcDomainKey domain - case mConfig of - Just cfg -> pure ( Right $ oidcDomainIssuer cfg - , ClientId $ oidcDomainClientId cfg) - Nothing -> error "No config for this domain" - getClientSecret clientId _ = pure $ fakeClientSecret clientId - onSuccessfulAuthentication _originalLoginHint _clientId _provider tokens mUserInfo = do - let idTok = idToken tokens - -- The 'email' is sometimes in the ID Token, and sometimes in the - -- UserInfo Response. Both are JSON objects. - let emailVal = - HM.lookup "email" (otherClaims idTok) - <|> (mUserInfo >>= HM.lookup "email") - emailAddr = case emailVal of - Just (J.String em) -> em - _ -> error "Spec-conforming email missing from ID token and/or User Info Response" - mUser <- liftHandler . runDB $ getBy $ UniqueUser (iss idTok) (sub idTok) - case mUser of - Just (Entity uid u) -> do - when (userEmail u /= emailAddr) $ - liftHandler . runDB $ update uid [ UserEmail =. emailAddr ] - pure $ toPathPiece uid - Nothing -> do - fmap toPathPiece $ liftHandler . runDB $ insert $ User - { userEmail = emailAddr - , userIssuer = iss idTok - , userSubject = sub idTok - } - -instance YesodAuthPersist App - -instance RenderMessage App FormMessage where - renderMessage _ _ = defaultFormMessage diff --git a/test/ExampleProvider.hs b/test/ExampleProvider.hs deleted file mode 100644 --- a/test/ExampleProvider.hs +++ /dev/null @@ -1,131 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{- -The code in this module is modified from that found in the -broch-server/broch.hs file in the 'broch' library, which is under the -following copyright and license: - ----------------------- - -Copyright (c) 2014, Luke Taylor - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR -CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; -OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR -OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF -ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - --} -module ExampleProvider where - -import ClassyPrelude -import ExampleProviderOpts - -import Broch.Model -import Broch.Server -import Broch.Server.Config -import Broch.Server.Internal -import Broch.Server.Session (defaultKey, defaultLoadSession) -import qualified Broch.SQLite as BS -import Broch.URI -import Crypto.KDF.BCrypt (hashPassword) -import Data.Aeson -import qualified Data.Map as M -import Data.Pool (createPool, withResource) -import qualified Database.SQLite.Simple as SQLite -import Network.Wai.Application.Static (defaultWebAppSettings, staticApp) -import Network.Wai.Handler.Warp (run) -import Network.Wai.Middleware.RequestLogger (logStdoutDev) -import System.Directory -import qualified Web.Routing.Combinators as R -import qualified Web.Routing.SafeRouting as R -import Yesod.Auth.OIDC (ClientId(..), ClientSecret(..)) - --- Adapted from Broch.SQLite -toJSONField :: ToJSON a => Maybe a -> SQLite.SQLData -toJSONField = maybe SQLite.SQLNull (SQLite.SQLText . decodeUtf8 . toStrict . encode) - --- Adapted from Broch.SQLite -insertClient :: SQLite.Connection -> Client -> IO () -insertClient conn Client{..} = - void $ SQLite.execute conn "INSERT INTO oauth2_client (id, secret, redirect_uri, allowed_scope, authorized_grant_types, access_token_validity, refresh_token_validity, auth_method, auth_alg, keys_uri, keys, id_token_algs, user_info_algs, request_obj_algs, sector_identifier, auto_approve) VALUES (?,?,?,?,?,?,?,?,?,?,?,?,?,?,?,?)" ((clientId, clientSecret, redirectURIs, allowedScope, authorizedGrantTypes, accessTokenValidity, refreshTokenValidity, clientAuthMethodName tokenEndpointAuthMethod, fmap tshow tokenEndpointAuthAlg, clientKeysUri) SQLite.:. (toJSONField clientKeys, toJSONField idTokenAlgs, toJSONField userInfoAlgs, toJSONField requestObjAlgs, sectorIdentifier, autoapprove)) - -initDB :: BrochOptions -> SQLite.Connection -> IO () -initDB BrochOptions{..} c = do - void $ flip M.traverseWithKey boClients $ \(ClientId clientId) (ClientSecret secret, host, callback) -> - insertClient c $ Client - { clientId = clientId - , clientSecret = Just secret - , authorizedGrantTypes = [AuthorizationCode] - , redirectURIs = case parseURI callback of - Right url -> [url] - Left e -> error $ "Can't initialise tests due to bad callback URL: " <> show e - , accessTokenValidity = 3600 - , refreshTokenValidity = 7200 - , allowedScope = [OpenID, Profile, Email] - , autoapprove = False - , tokenEndpointAuthMethod = ClientSecretPost - , tokenEndpointAuthAlg = Nothing -- :: Maybe JwsAlg - , clientKeysUri = Nothing -- :: Maybe Text - , clientKeys = Just [] -- :: Maybe [Jwk] - , idTokenAlgs = Nothing -- :: Maybe AlgPrefs - , userInfoAlgs = Nothing -- :: Maybe AlgPrefs - , requestObjAlgs = Nothing -- :: Maybe AlgPrefs - , sectorIdentifier = host - } - void $ flip M.traverseWithKey boUsers $ \userId (emailAddr, pw) -> do - pwHash :: ByteString <- hashPassword 6 (encodeUtf8 pw) - void $ SQLite.execute c "INSERT OR REPLACE INTO op_user VALUES (?, ?, ?, 'key')" ((userId, userId, pwHash)) - void $ SQLite.execute c "INSERT OR REPLACE INTO user_info VALUES (?, 'name', 'first', 'last', 'middle', 'nick', 'name', 'http://placeholder', 'http://placeholder', 'http://placeholder', ?, 0, null, '2000-01-01', 'Europe/Paris', 'en-US', '+33 12 34 56 78', 0, '25 My Street, Village, 1234567, France', '25 My Street', 'Vilage', 'Shire', '1234567', 'EN', datetime('now'))" ((userId, emailAddr)) - - -runBroch :: BrochOptions -> IO () -runBroch opts@BrochOptions{..} = do - sessionKey <- defaultKey - kr <- defaultKeyRing - rotateKeys kr True - let dbFile = "broch.sqlite3" - dbExists <- doesFileExist dbFile - when dbExists $ removeFile dbFile - pool <- createPool (SQLite.open dbFile) SQLite.close 1 60 20 - withResource pool BS.createSchema - config <- BS.sqliteBackend pool <$> inMemoryConfig boIssuerUri kr Nothing - let app = staticApp (defaultWebAppSettings "webroot") - baseRouter = brochServer config defaultApprovalPage authenticatedSubject authenticateSubject - authenticate username password = pure $ M.lookup username boUsers >>= \case - (_, pw) | pw == password -> Just username - _ -> Nothing - extraRoutes = - [ ("/home", text "Hello, I'm the home page") - , ("/login", passwordLoginHandler defaultLoginPage authenticate) - , ("/logout", invalidateSession >> text "You have been logged out") - ] - router = foldl' (\pathMap (r, h) -> R.insertPathMap' (R.toInternalPath (R.static r)) (const h) pathMap) baseRouter extraRoutes - broch = routerToMiddleware (defaultLoadSession 3600 sessionKey) boIssuerUri router - - withResource pool $ initDB opts - - run boPort (logStdoutDev (broch app)) diff --git a/test/ExampleProviderOpts.hs b/test/ExampleProviderOpts.hs deleted file mode 100644 --- a/test/ExampleProviderOpts.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module ExampleProviderOpts where - -import ClassyPrelude -import Yesod.Auth.OIDC - --- Quick-and-dirty type synonyms just for testing -type Domain = Text -type Email = Text -type SubjectId = Text -type ClientHost = Text -type CallbackUri = Text -type Password = Text - --- | You should store your client secrets as you would for other --- credentials in your app. -fakeClientSecret :: ClientId -> ClientSecret -fakeClientSecret (ClientId cid) = - -- You should not hardcode it like this: - ClientSecret $ cid <> "_secret" - --- | We use the 'broch' library as a local OIDC Provider. You do not --- need something like this in your client app. -data BrochOptions = BrochOptions - { boIssuerUri :: Text - , boPort :: Int - , boUsers :: Map SubjectId (Email, Password) - , boClients :: Map ClientId (ClientSecret, ClientHost, CallbackUri) - } diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TestImport.hs b/test/TestImport.hs deleted file mode 100644 --- a/test/TestImport.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} - -module TestImport - ( module TestImport - , module X - ) where - -import ClassyPrelude as X hiding (Handler, delete, deleteBy) -import Control.Monad.Logger (runLoggingT) -import qualified Data.Map as M -import Database.Persist as X hiding (get) -import Database.Persist.Sql (runMigration, runSqlPool) -import Database.Persist.Sqlite (createSqlitePool) -import ExampleApp as X -import ExampleProvider as Broch -import ExampleProviderOpts as X -import Network.HTTP.Client -import Network.Wai.Handler.Warp -import Network.Wai.Middleware.RequestLogger (logStdoutDev) -import System.Directory -import System.Log.FastLogger (newStdoutLoggerSet) -import Test.Hspec as X -import Yesod hiding (get) -import Yesod.Auth.OIDC as X hiding (exp) -import Yesod.Core as X -import qualified Yesod.Core.Unsafe as Unsafe -import Yesod.Default.Config2 (makeYesodLogger) -import Yesod.Persist.Core as X - -type TestArgs = (Async (), Async (), App, BrochOptions) - -user1 :: (SubjectId, (Email, Password)) -user1 = ("user1", ("user1@example.local", "password1")) - -brochUsers :: Map SubjectId (Email, Password) -brochUsers = M.fromList - [ user1 - , ("user2", ("user2@sub.example.local", "password2")) - ] - -withServers :: SpecWith TestArgs -> Spec -withServers = beforeAll runServers . afterAll stopServers - where - appPort = 4049 - appHost = "http://localhost:" <> tshow appPort - boPort = 4050 - boIssuerUri = "http://localhost:" <> tshow boPort - boUsers = brochUsers - appBrochClientId = ClientId "client1" - boClients = M.fromList - [ (appBrochClientId, ( fakeClientSecret appBrochClientId - , appHost - , appHost <> "/auth/page/oidc/callback")) - ] - brochOptions = BrochOptions{..} - runServers = do - brochA <- async $ Broch.runBroch brochOptions - appLogger <- newStdoutLoggerSet 1 >>= makeYesodLogger - appHttpManager <- newManager defaultManagerSettings - let mkFoundation appConnPool = App {..} - tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" - logFunc = messageLoggerSource tempFoundation appLogger - removeIfExists "auth.sqlite3" - pool <- flip runLoggingT logFunc $ createSqlitePool "auth.sqlite3" 10 - runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc - let app = mkFoundation pool - waiApp <- toWaiAppPlain app - appA <- async $ run appPort $ logStdoutDev waiApp - pure (brochA, appA, app, brochOptions) - stopServers (brochA, appA, _, _) = do - cancel brochA - cancel appA - -unsafeHandler :: App -> Handler a -> IO a -unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger - -removeIfExists :: FilePath -> IO () -removeIfExists f = do - fileExists <- doesFileExist f - when fileExists (removeFile f) diff --git a/test/Yesod/Auth/OIDCSpec.hs b/test/Yesod/Auth/OIDCSpec.hs deleted file mode 100644 --- a/test/Yesod/Auth/OIDCSpec.hs +++ /dev/null @@ -1,105 +0,0 @@ -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} - -module Yesod.Auth.OIDCSpec (spec) where - -import Control.Lens ((^.)) -import qualified Control.Lens.Regex.Text as Regex -import qualified Data.Map as M -import qualified Data.Set as Set -import qualified Data.Text as T -import Network.HTTP.Client -import Network.HTTP.Types.Status -import TestImport - -spec :: Spec -spec = withServers $ do - describe "login with OpenID Connect" $ do - it "can login with OIDC" $ \(_, _, app@App{..}, BrochOptions{..}) -> do - -- In this test, the ExampleProvider has already been populated - -- with the user, and the ExampleApp is configured to insert new - -- users into its local database upon successful - -- authentication. We first configure our client app for this - -- provider: - unsafeHandler app $ runDB $ do - insert_ $ OidcConfig - { oidcConfigClientId = unClientId appBrochClientId - , oidcConfigIssuer = boIssuerUri - } - let domains = Set.toList . Set.fromList - $ map (snd . T.breakOnEnd "@" . fst) $ M.elems brochUsers - insertMany_ $ flip map domains $ \domain -> OidcDomain - { oidcDomainDomain = domain - , oidcDomainClientId = unClientId appBrochClientId - , oidcDomainIssuer = boIssuerUri - } - - ur <- unsafeHandler app getUrlRender - let - mgr = appHttpManager - mkReq = parseRequest_ . unpack . (appHost <>) . ur - protectedReq = mkReq ProtectedResourceR - tokenReq = mkReq CsrfTokenR - forwardReq = mkReq $ AuthR oidcForwardR - - -- Assert that we can't get the ProtectedResource yet - protectedRes0 <- httpNoBody protectedReq mgr - liftIO $ responseStatus protectedRes0 `shouldBe` status403 - - -- Get the csrf token (Yesod's default csrf handling is - -- session-specific rather than request-specific). - tokenResp <- httpLbs tokenReq mgr - let token = toStrict $ responseBody tokenResp - - -- POST to the oidcForwardR with correct params. - let (user1_id, (user1_email, user1_pw)) = user1 - respForwardR <- httpLbs - (urlEncodedBody - [ (encodeUtf8 defaultCsrfParamName, token) - , ("email", encodeUtf8 user1_email) - ] $ forwardReq { method = "POST" - , cookieJar = Just $ responseCookieJar tokenResp }) - mgr - let - respForwardR_body = toStrict $ decodeUtf8 (responseBody respForwardR) - brochCsrfToken = respForwardR_body - ^. [Regex.regex|name="_rid" value="([^"]*)">|] - . Regex.group 0 - - -- POST the provider's login URL with username and password. - let loginReq = urlEncodedBody - [ ("username", encodeUtf8 user1_id) - , ("password", encodeUtf8 user1_pw) - , ("_rid", encodeUtf8 brochCsrfToken) - ] $ (parseRequest_ (unpack $ boIssuerUri <> "/login")) - { method = "POST" - , cookieJar = Just $ responseCookieJar respForwardR - } - respProviderLogin <- httpLbs loginReq mgr - - -- POST the provider's scope approval form - let - expiryParam = - (toStrict $ decodeUtf8 $ responseBody respProviderLogin) - ^. [Regex.regex|"expiry">