From 4aeceefbe656906617ea7baf0e4b834ab5b59b16 Mon Sep 17 00:00:00 2001 From: AaronFriel Date: Fri, 15 Sep 2017 13:11:08 -0500 Subject: [PATCH] Significant cleanup of OAuth2 api sections. --- guide.cabal | 7 +- src/Guide/Auth.hs | 32 ++--- src/Guide/Auth/OAuth2.hs | 43 ++----- .../Auth/OAuth2/{GitHub.hs => Github.hs} | 112 ++++++++---------- src/Guide/Auth/OAuth2/Google.hs | 2 + src/Guide/Config.hs | 4 +- src/Guide/Config/OAuth2.hs | 2 +- src/Guide/Config/OAuth2/Base.hs | 36 +++--- src/Guide/Config/OAuth2/GitHub.hs | 73 ------------ src/Guide/Config/OAuth2/Github.hs | 84 +++++++++++++ src/Guide/Config/OAuth2/Google.hs | 41 +------ src/Guide/State.hs | 11 +- src/Guide/Types/AccessToken.hs | 2 +- src/Guide/Types/Creds.hs | 9 +- src/Guide/Types/OAuth2.hs | 2 +- src/Guide/Views/Auth/Profile.hs | 2 +- 16 files changed, 208 insertions(+), 254 deletions(-) rename src/Guide/Auth/OAuth2/{GitHub.hs => Github.hs} (68%) delete mode 100644 src/Guide/Config/OAuth2/GitHub.hs create mode 100644 src/Guide/Config/OAuth2/Github.hs diff --git a/guide.cabal b/guide.cabal index 6f12b49..78a129a 100644 --- a/guide.cabal +++ b/guide.cabal @@ -38,7 +38,7 @@ executable guide build-depends: base , guide ghc-options: -Wall -fno-warn-unused-do-bind - -- -threaded "-with-rtsopts=-T -N" + -threaded "-with-rtsopts=-T -N" hs-source-dirs: src/site default-language: Haskell2010 @@ -56,7 +56,7 @@ library Guide.State Guide.Auth Guide.Auth.OAuth2 - Guide.Auth.OAuth2.GitHub + Guide.Auth.OAuth2.Github Guide.Auth.OAuth2.Google Guide.Types Guide.Types.Hue @@ -68,7 +68,7 @@ library Guide.Types.Session Guide.Config.OAuth2 Guide.Config.OAuth2.Base - Guide.Config.OAuth2.GitHub + Guide.Config.OAuth2.Github Guide.Config.OAuth2.Google Guide.Handlers Guide.Utils @@ -99,6 +99,7 @@ library , acid-state == 0.14.* , aeson == 1.0.* , aeson-pretty + , unordered-containers >= 0.2.8 , base >=4.9 && <4.10 , base-prelude , bytestring diff --git a/src/Guide/Auth.hs b/src/Guide/Auth.hs index 32b5b25..cced43a 100644 --- a/src/Guide/Auth.hs +++ b/src/Guide/Auth.hs @@ -5,6 +5,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} + {- | Module  : Guide.Auth Description : Authentication module @@ -17,28 +19,28 @@ Portability : portable -} -{-# LANGUAGE TypeFamilies #-} - module Guide.Auth where --- Web --- import Lucid hiding (for_) --- import Network.Wai.Middleware.Static (addBase, staticPolicy) -import Web.Routing.Combinators (PathState (Open)) -import Web.Spock hiding (get, head, text) --- import qualified Web.Spock as Spock --- import Web.Spock.Config --- import Web.Spock.Lucid - import Imports +-- Web +import Web.Routing.Combinators (PathState (Open)) +import Web.Spock hiding (get, head, text) + import Guide.App import Guide.Auth.OAuth2 --- import Guide.Config --- import Guide.Config.OAuth2 --- import Guide.Routes --- import Guide.ServerStuff +-- | This function adds handlers for all authentication routes that +-- we need to support. Assuming that the prefix is @auth@, 'mkAuthApi' +-- will add handlers for these routes: +-- +-- @ +-- /auth/oauth2/github/... +-- /auth/oauth2/google/... +-- /auth/oauth2/generic/... +-- @ +-- +-- For details on the created routes, see 'mkOAuth2Api', 'mkGithubAuth', etc. mkAuthApi :: Path '[] 'Open -> GuideM ctx () mkAuthApi prefix = do mkOAuth2Api $ prefix "oauth2" diff --git a/src/Guide/Auth/OAuth2.hs b/src/Guide/Auth/OAuth2.hs index 04898ee..bba6215 100644 --- a/src/Guide/Auth/OAuth2.hs +++ b/src/Guide/Auth/OAuth2.hs @@ -1,9 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} {- | Module  : Guide.Auth.OAuth2 @@ -17,38 +12,24 @@ Portability : portable -} -{-# LANGUAGE TypeFamilies #-} +module Guide.Auth.OAuth2 +( + mkOAuth2Api +) +where -module Guide.Auth.OAuth2 where - --- Web --- import Lucid hiding (for_) --- import Network.Wai.Middleware.Static (addBase, staticPolicy) -import Web.Routing.Combinators (PathState (Open)) -import Web.Spock hiding (get, head, text) --- import qualified Web.Spock as Spock --- import Web.Spock.Config --- import Web.Spock.Lucid import Imports -import Guide.App -import Guide.Auth.OAuth2.GitHub --- import Guide.Config.OAuth2 --- import Guide.Routes -import Guide.ServerStuff +-- Web +import Web.Routing.Combinators (PathState (Open)) +import Web.Spock hiding (get, head, text) +import Guide.App +import Guide.Auth.OAuth2.Github +import Guide.ServerStuff mkOAuth2Api :: Path '[] 'Open -> GuideM ctx () mkOAuth2Api prefix = do - _cfg <- getConfig - _ <- mkGitHubAuth $ prefix "github" - -- Spock.get "foo" $ _foo + mkGithubAuth $ prefix "github" return () - - --- mkAuthApi :: Path '[] 'Open -> GuideApp () --- mkAuthApi prefix = do --- let OAuth2route r = prefix "OAuth2" r --- cfg <- getSpockCfg --- Spock.get (OAuth2route "google") undefined diff --git a/src/Guide/Auth/OAuth2/GitHub.hs b/src/Guide/Auth/OAuth2/Github.hs similarity index 68% rename from src/Guide/Auth/OAuth2/GitHub.hs rename to src/Guide/Auth/OAuth2/Github.hs index 93c8b86..755c989 100644 --- a/src/Guide/Auth/OAuth2/GitHub.hs +++ b/src/Guide/Auth/OAuth2/Github.hs @@ -1,13 +1,11 @@ {-# LANGUAGE DataKinds #-} --- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} --- {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} --- {-# LANGUAGE TypeOperators #-} {- | -Module  : Guide.Auth.OAuth2.GitHub -Description : GitHub authentication module +Module  : Guide.Auth.OAuth2.Github +Description : Github authentication module Copyright  : (c) Aaron Friel License  : BSD-3 @@ -17,83 +15,77 @@ Portability : portable -} -module Guide.Auth.OAuth2.GitHub where +module Guide.Auth.OAuth2.Github +( + mkGithubAuth +) +where -import Imports +import Imports -- text -import qualified Data.Text.All as T +import qualified Data.Text.All as T -- JSON -import Data.Aeson as Aeson --- import Data.Aeson.Encode.Pretty as Aeson hiding (Config) +import Data.Aeson as Aeson -- Map -import qualified Data.Map as Map +import qualified Data.Map as Map -- Web --- import Lucid hiding (for_) --- import Network.Wai.Middleware.Static (addBase, staticPolicy) -import Web.Routing.Combinators (PathState (Open)) -import Web.Spock hiding (get, head, text) -import qualified Web.Spock as Spock --- import Web.Spock.Config --- import Web.Spock.Lucid - --- import Imports +import Web.Routing.Combinators (PathState (Open)) +import Web.Spock hiding (get, head, text) +import qualified Web.Spock as Spock import Guide.App --- import Guide.Auth.OAuth2.GitHub import Guide.Config import Guide.Config.OAuth2 import Guide.Handlers --- import Guide.Routes import Guide.ServerStuff -import Guide.Types.Session import Guide.Types.Creds +import Guide.Types.Session import Guide.Types.User +import Guide.Utils --- import Guide.Views.Utils +import Guide.State -import Guide.State - -import Network.HTTP.Client -import Network.HTTP.Types.Status -import Network.OAuth.OAuth2 +import Network.HTTP.Client +import Network.HTTP.Types.Status +import Network.OAuth.OAuth2 data GithubUser = GithubUser - { githubUserId :: Int - , githubUserName :: Maybe Text - , githubUserLogin :: Text - , githubUserAvatarUrl :: Text - , githubUserLocation :: Maybe Text + { githubUserId :: Int + -- | The user's "Name", not their username. + , githubUserName :: Maybe Text + , githubUserLogin :: Text + , githubUserAvatarUrl :: Url + , githubUserLocation :: Maybe Text , githubUserPublicEmail :: Maybe Text } + deriving (Show) instance FromJSON GithubUser where - parseJSON (Object o) = GithubUser - <$> o .: "id" - <*> o .:? "name" - <*> o .: "login" - <*> o .: "avatar_url" - <*> o .:? "location" - <*> o .:? "email" - - parseJSON _ = mzero + parseJSON = withObject "GithubUser" $ \o -> do + githubUserId <- o .: "id" + githubUserName <- o .:? "name" + githubUserLogin <- o .: "login" + githubUserAvatarUrl <- o .: "avatar_url" + githubUserLocation <- o .:? "location" + githubUserPublicEmail <- o .:? "email" + return GithubUser {..} data GithubUserEmail = GithubUserEmail { githubUserEmailAddress :: Text , githubUserEmailPrimary :: Bool } + deriving (Show) instance FromJSON GithubUserEmail where - parseJSON (Object o) = GithubUserEmail - <$> o .: "email" - <*> o .: "primary" + parseJSON = withObject "GithubUserEmail" $ \o -> do + githubUserEmailAddress <- o .: "email" + githubUserEmailPrimary <- o .: "primary" + return GithubUserEmail {..} - parseJSON _ = mzero - - -mkGitHubAuth :: Path '[] 'Open -> GuideM ctx () -mkGitHubAuth prefix = do +mkGithubAuth :: Path '[] 'Open -> GuideM ctx () +mkGithubAuth prefix = do cfg <- getConfig mgr <- getManager baseUrl <- _baseUrl <$> getConfig @@ -166,26 +158,26 @@ fetchGithubProfile manager token = do mailResult <- authGetJSON manager token "https://api.github.com/user/emails" case (userResult, mailResult) of - (Right _, Right []) -> return Nothing -- throwIO $ InvalidProfileResponse "github" "no mail address for user" + (Right _, Right []) -> return Nothing -- throwIO $ InvalidProfileResponse "github" "no mail address for user" (Right user, Right mails) -> return . Just $ toCreds user mails token - (Left _err, _) -> return $ Nothing -- throwIO $ InvalidProfileResponse "github" err - (_, Left _err) -> return $ Nothing -- throwIO $ InvalidProfileResponse "github" err + (Left _err, _) -> return $ Nothing -- throwIO $ InvalidProfileResponse "github" err + (_, Left _err) -> return $ Nothing -- throwIO $ InvalidProfileResponse "github" err toCreds :: GithubUser -> [GithubUserEmail] -> AccessToken -> Creds toCreds user userMails token = makeCreds "github" ident extra where ident = T.pack $ show $ githubUserId user extra = Map.fromList $ - - Nothing - `maybeCons` [ ("email", githubUserEmailAddress email), ("login", githubUserLogin user), ("avatar_url", githubUserAvatarUrl user), ("access_token", T.decodeUtf8 $ accessToken token) ] + `maybePrepend` ("name", githubUserName user) + `maybePrepend` ("public_email", githubUserPublicEmail user) + `maybePrepend` ("location", githubUserLocation user) email = fromMaybe (head userMails) $ find githubUserEmailPrimary userMails -maybeCons :: Maybe a -> [a] -> [a] -maybeCons Nothing as = as -maybeCons (Just a) as = a : as +maybePrepend :: [(a,b)] -> (a, Maybe b) -> [(a,b)] +maybePrepend xs (_, Nothing ) = xs +maybePrepend xs (a, (Just b)) = (a, b) : xs diff --git a/src/Guide/Auth/OAuth2/Google.hs b/src/Guide/Auth/OAuth2/Google.hs index 47afdee..7d2384e 100644 --- a/src/Guide/Auth/OAuth2/Google.hs +++ b/src/Guide/Auth/OAuth2/Google.hs @@ -11,3 +11,5 @@ Portability : portable -} module Guide.Auth.OAuth2.Google where + +-- TODO \ No newline at end of file diff --git a/src/Guide/Config.hs b/src/Guide/Config.hs index 873f44d..3219387 100644 --- a/src/Guide/Config.hs +++ b/src/Guide/Config.hs @@ -47,8 +47,8 @@ data Config = Config { -- the app is started _discussLink :: Maybe Url, -- ^ Link to a place to discuss the site. -- Will be placed in the header - _githubOauth :: Maybe OAuth2.GitHubEndpoint - -- ^ Configuration for GitHub based OAuth + _githubOauth :: Maybe OAuth2.GithubEndpoint + -- ^ Configuration for Github based OAuth } deriving (Eq, Show) diff --git a/src/Guide/Config/OAuth2.hs b/src/Guide/Config/OAuth2.hs index 1d73023..7f6dcd7 100644 --- a/src/Guide/Config/OAuth2.hs +++ b/src/Guide/Config/OAuth2.hs @@ -18,5 +18,5 @@ module Guide.Config.OAuth2 ) where import Guide.Config.OAuth2.Base as X -import Guide.Config.OAuth2.GitHub as X +import Guide.Config.OAuth2.Github as X import Guide.Config.OAuth2.Google as X diff --git a/src/Guide/Config/OAuth2/Base.hs b/src/Guide/Config/OAuth2/Base.hs index 88d504a..193ef7f 100644 --- a/src/Guide/Config/OAuth2/Base.hs +++ b/src/Guide/Config/OAuth2/Base.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + {- | Module  : Guide.Config.OAuth2.Base Description : OAuth2 data definitions @@ -10,37 +14,31 @@ Portability : portable -} -{-# LANGUAGE OverloadedStrings #-} - module Guide.Config.OAuth2.Base where -import Imports hiding ((.=)) - --- acid-state --- import Data.SafeCopy hiding (kind) - -import Guide.Utils +import Imports hiding ((.=)) -- hoauth2 -import Network.OAuth.OAuth2 +import Network.OAuth.OAuth2 -- text -import qualified Data.Text.All as T - --- import Guide.Types.User +import qualified Data.Text.All as T -- Aeson -import Data.Aeson -import Data.Aeson.Encode.Pretty --- ByteString --- import qualified Data.ByteString as BS --- import qualified Data.ByteString.Lazy as BSL +import Data.Aeson +import Data.Aeson.Encode.Pretty -- Default -import Data.Default +import Data.Default + +import Guide.Utils + -- | Configuration details to access an endpoint. -- -- Intended to be used in a config file. -- -- See note [OAuth2 workflow] +-- +-- Note that some of these parameters may be "read only" in the configuration, +-- and overwritten by an authorization provider. data OAuth2Endpoint = OAuth2Endpoint { _endpointName :: Text, -- ^ A unique name for the OAuth2 endpoint. _endpointClientId :: Text, -- ^ The client ID for the OAuth2 endpoint. @@ -123,4 +121,4 @@ instance HasOAuth2Endpoint OAuth2Endpoint where Each instance of an OAuth2 endpoint then will contain a OAuth2Endpoint field, and implement the above type classes. --} \ No newline at end of file +-} diff --git a/src/Guide/Config/OAuth2/GitHub.hs b/src/Guide/Config/OAuth2/GitHub.hs deleted file mode 100644 index 15bdeb4..0000000 --- a/src/Guide/Config/OAuth2/GitHub.hs +++ /dev/null @@ -1,73 +0,0 @@ -{- | -Module  : Guide.Config.OAuth2.GitHub -Description : GitHub OAuth2 authentication parameters & workflow. -Copyright  : (c) Aaron Friel -License  : BSD-3 - -Maintainer  : Aaron Friel -Stability  : unstable | experimental | provisional | stable | frozen -Portability : portable | non-portable () - --} - -{-# LANGUAGE OverloadedStrings #-} - -module Guide.Config.OAuth2.GitHub where - -import Imports - --- acid-state --- import Data.SafeCopy hiding (kind) - --- import Guide.Utils --- import Guide.Types.User --- Aeson -import Data.Aeson --- import Data.Aeson.Encode.Pretty --- ByteString --- import qualified Data.ByteString as BS --- import qualified Data.ByteString.Lazy as BSL --- Default -import Data.Default - -import Guide.Config.OAuth2.Base - --- | GitHub authentication details -data GitHubEndpoint = GitHubEndpoint { - _githubBaseConfig :: OAuth2Endpoint - } - deriving (Eq, Show) - -makeClassy ''GitHubEndpoint - -instance Default GitHubEndpoint where - def = GitHubEndpoint { - _githubBaseConfig = def { - _endpointName = "GitHub", - _endpointAuthorize = "https://github.com/login/oauth/authorize?scope=user:email", - _endpointAccessToken = "https://github.com/login/oauth/access_token" - } - } - -instance FromJSON GitHubEndpoint where - parseJSON (Object o) = do - let def' = def :: GitHubEndpoint - _githubBaseConfig <- do - _endpointName <- o .:? "name" .!= (def' ^. endpointName) - _endpointClientId <- o .:? "client-id" .!= (def' ^. endpointClientId) - _endpointClientSecret <- o .:? "client-secret" .!= (def' ^. endpointClientSecret) - _endpointAuthorize <- o .:? "authorize-url" .!= (def' ^. endpointAuthorize) - _endpointAccessToken <- o .:? "access-token-url" .!= (def' ^. endpointAccessToken) - _endpointCallback <- o .:? "callback-url" .!= (def' ^. endpointCallback) - return $ OAuth2Endpoint {..} - return $ GitHubEndpoint {..} - -instance ToJSON GitHubEndpoint where - toJSON GitHubEndpoint{..} = - Object base - where - (Object base) = toJSON _githubBaseConfig - - -instance HasOAuth2Endpoint GitHubEndpoint where - oAuth2Endpoint = githubBaseConfig diff --git a/src/Guide/Config/OAuth2/Github.hs b/src/Guide/Config/OAuth2/Github.hs new file mode 100644 index 0000000..c1664be --- /dev/null +++ b/src/Guide/Config/OAuth2/Github.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +{- | +Module  : Guide.Config.OAuth2.Github +Description : Github OAuth2 authentication parameters & workflow. +Copyright  : (c) Aaron Friel +License  : BSD-3 + +Maintainer  : Aaron Friel +Stability  : unstable +Portability : portable | non-portable () + +-} + +module Guide.Config.OAuth2.Github where + +import Imports hiding ((.=)) + +-- Aeson +import Data.Aeson +-- Default +import Data.Default +-- Text +import qualified Data.Text.All as T +-- unordered-containers +import qualified Data.HashMap.Lazy as HashMap + +import Guide.Config.OAuth2.Base +import Guide.Utils + +-- | Github authentication details +data GithubEndpoint = GithubEndpoint { + _githubBaseConfig :: OAuth2Endpoint, + _githubScopes :: [Text] + } + deriving (Eq, Show) + +makeClassy ''GithubEndpoint + +-- Constants +defAuthorize, defAccessToken :: Url +defAuthorize = "https://github.com/login/oauth/authorize?scope=" +defAccessToken = "https://github.com/login/oauth/access_token" + + +instance Default GithubEndpoint where + def = + GithubEndpoint { + _githubScopes = defaultScopes, + _githubBaseConfig = def { + _endpointName = "Github", + _endpointAuthorize = defAuthorize <> T.intercalate "," defaultScopes, + _endpointAccessToken = defAccessToken + } + } + where + defaultScopes = ["user:email"] + +instance FromJSON GithubEndpoint where + parseJSON (Object o) = do + let def' = def :: GithubEndpoint + _githubScopes <- o .:? "scopes" .!= (def' ^. githubScopes) + _githubBaseConfig <- do + _endpointName <- o .:? "name" .!= (def' ^. endpointName) + _endpointClientId <- o .:? "client-id" .!= (def' ^. endpointClientId) + _endpointClientSecret <- o .:? "client-secret" .!= (def' ^. endpointClientSecret) + let _endpointAuthorize = defAuthorize <> T.intercalate "," _githubScopes + let _endpointAccessToken = defAccessToken + _endpointCallback <- o .:? "callback-url" .!= (def' ^. endpointCallback) + return $ OAuth2Endpoint {..} + return $ GithubEndpoint {..} + +instance ToJSON GithubEndpoint where + toJSON GithubEndpoint{..} = + Object $ ext `HashMap.union` base + where + (Object base) = toJSON _githubBaseConfig + (Object ext) = object [ + "scopes" .= _githubScopes ] + +instance HasOAuth2Endpoint GithubEndpoint where + oAuth2Endpoint = githubBaseConfig diff --git a/src/Guide/Config/OAuth2/Google.hs b/src/Guide/Config/OAuth2/Google.hs index 5fa31d1..473d48a 100644 --- a/src/Guide/Config/OAuth2/Google.hs +++ b/src/Guide/Config/OAuth2/Google.hs @@ -5,7 +5,7 @@ Copyright  : (c) Aaron Friel License  : BSD-3 Maintainer  : Aaron Friel -Stability  : unstable | experimental | provisional | stable | frozen +Stability  : unstable Portability : portable | non-portable () -} @@ -14,41 +14,4 @@ Portability : portable | non-portable () module Guide.Config.OAuth2.Google where -import Imports - --- acid-state --- import Data.SafeCopy hiding (kind) - --- import Guide.SafeCopy --- import Guide.Utils --- import Guide.Types.User --- Aeson --- import Data.Aeson --- import Data.Aeson.Encode.Pretty --- ByteString --- import qualified Data.ByteString as BS --- import qualified Data.ByteString.Lazy as BSL --- Default -import Guide.Config.OAuth2.Base - --- | Google authentication details -data GoogleEndpoint = GoogleEndpoint { - _googleEndpointConfig :: OAuth2Endpoint - } - deriving (Eq, Show) - -makeClassy ''GoogleEndpoint - --- instance OAuth2Default GoogleEndpoint where --- oauth2def baseUrl = GoogleEndpoint { --- _googleEndpointConfig = (oauth2def baseUrl) { --- _endpointName = "Google", --- _endpointAuthorize = "https://accounts.google.com/o/OAuth2/v2/auth", --- _endpointAccessToken = "https://www.googleapis.com/OAuth2/v4/token" --- } --- } - -instance HasOAuth2Endpoint GoogleEndpoint where - oAuth2Endpoint = googleEndpointConfig - --- type OAuth2Callback = \ No newline at end of file +-- TODO \ No newline at end of file diff --git a/src/Guide/State.hs b/src/Guide/State.hs index 14f9e3b..185ba1c 100644 --- a/src/Guide/State.hs +++ b/src/Guide/State.hs @@ -886,7 +886,7 @@ addCreds user userCreds = do else return False --- | Remove external credentials to a user account. +-- | Remove external credentials from a user account. removeCreds :: User -> Creds -> Acid.Update GlobalState () removeCreds user userCreds = do creds %= M.adjust (filter filterCred) (user ^. userID) @@ -899,13 +899,12 @@ removeCreds user userCreds = do -- | Get user from creds loginUserCreds :: Creds -> Acid.Query GlobalState (Maybe User) loginUserCreds userCreds = do - matches <- filter (\(_, cs) -> any matchCred cs) . M.toList <$> view creds + matches <- filter (\(_, cs) -> any (userCreds==) cs) . M.toList <$> view creds case matches of [(key, _)] -> view (users . at key) - _ -> return Nothing - where - matchCred cred = cred ^. credsProvider == userCreds ^. credsProvider - && cred ^. credsId == userCreds ^. credsId + [] -> return Nothing + _ -> error $ "loginUserCreds: More than one credential matched," + <> " a duplicate credential exists in the database." -- | Populate the database with info from the public DB. importPublicDB :: PublicDB -> Acid.Update GlobalState () diff --git a/src/Guide/Types/AccessToken.hs b/src/Guide/Types/AccessToken.hs index bd19809..001d7eb 100644 --- a/src/Guide/Types/AccessToken.hs +++ b/src/Guide/Types/AccessToken.hs @@ -5,7 +5,7 @@ Copyright  : (c) Aaron Friel License  : BSD-3 Maintainer  : Aaron Friel -Stability  : unstable | experimental | provisional | stable | frozen +Stability  : unstable Portability : portable | non-portable () moduleLongerDescription diff --git a/src/Guide/Types/Creds.hs b/src/Guide/Types/Creds.hs index 4543bb1..912497e 100644 --- a/src/Guide/Types/Creds.hs +++ b/src/Guide/Types/Creds.hs @@ -1,11 +1,11 @@ {- | Module  : Guide.Types.Creds -Description : Credentials for external providers (e.g.: GitHub authentication) +Description : Credentials for external providers (e.g.: Github authentication) Copyright  : (c) Aaron Friel License  : BSD-3 Maintainer  : Aaron Friel -Stability  : unstable | experimental | provisional | stable | frozen +Stability  : unstable Portability : portable | non-portable () -} @@ -45,6 +45,11 @@ data Creds = Creds { deriveSafeCopySorted 0 'base ''Creds makeLenses ''Creds +instance Eq Creds where + credFoo == credBar = + credFoo ^. credsProvider == credBar ^. credsProvider + && credFoo ^. credsId == credBar ^. credsId + makeCreds :: Text -> Text -> Map Text Text -> Creds makeCreds = Creds diff --git a/src/Guide/Types/OAuth2.hs b/src/Guide/Types/OAuth2.hs index eadfbb5..bf04d51 100644 --- a/src/Guide/Types/OAuth2.hs +++ b/src/Guide/Types/OAuth2.hs @@ -16,7 +16,7 @@ where import Guide.App -import qualified Guide.Config.OAuth2.GitHub as X +import qualified Guide.Config.OAuth2.Github as X import qualified Guide.Config.OAuth2.Google as X import qualified Guide.Config.OAuth2 as X diff --git a/src/Guide/Views/Auth/Profile.hs b/src/Guide/Views/Auth/Profile.hs index d2d8203..cd15e45 100644 --- a/src/Guide/Views/Auth/Profile.hs +++ b/src/Guide/Views/Auth/Profile.hs @@ -5,7 +5,7 @@ Copyright  : (c) Aaron Friel License  : BSD-3 Maintainer  : Aaron Friel -Stability  : unstable | experimental | provisional | stable | frozen +Stability  : unstable Portability : portable | non-portable () Should display the user's current information, any available options for changing,