Significant cleanup of OAuth2 api sections.

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

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"

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

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,7 +15,11 @@ Portability :  portable
 
 -}
 
-module Guide.Auth.OAuth2.GitHub where
+module Guide.Auth.OAuth2.Github
+(
+  mkGithubAuth
+)
+where
 
 import           Imports
 
@@ -25,33 +27,23 @@ import Imports
 import qualified Data.Text.All             as T
 -- JSON
 import           Data.Aeson                as Aeson
--- import Data.Aeson.Encode.Pretty as Aeson hiding (Config)
 -- 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           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.Views.Utils
+import           Guide.Utils
 
 import           Guide.State
 
@@ -61,39 +53,39 @@ import Network.OAuth.OAuth2
 
 data GithubUser = GithubUser
   { githubUserId          :: Int
+  -- | The user's "Name", not their username.
   , githubUserName        :: Maybe Text
   , githubUserLogin       :: Text
-  , githubUserAvatarUrl :: 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
@@ -176,16 +168,16 @@ 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

src/Guide/Auth/OAuth2/Google.hs

@@ -11,3 +11,5 @@ Portability :  portable
 -}
 
 module Guide.Auth.OAuth2.Google where
+
+-- TODO

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)
 

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

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
-
 -- hoauth2
 import           Network.OAuth.OAuth2
 -- text
 import qualified Data.Text.All            as T
-
--- 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.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.

src/Guide/Config/OAuth2/GitHub.hs

@@ -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 <mayreply@aaronfriel.com>
-Stability   :  unstable | experimental | provisional | stable | frozen
-Portability :  portable | non-portable (<reason>)
-
--}
-
-{-# 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

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 <mayreply@aaronfriel.com>
+Stability   :  unstable
+Portability :  portable | non-portable (<reason>)
+
+-}
+
+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

src/Guide/Config/OAuth2/Google.hs

@@ -5,7 +5,7 @@ Copyright   :  (c) Aaron Friel
 License     :  BSD-3
 
 Maintainer  :  Aaron Friel <mayreply@aaronfriel.com>
-Stability   :  unstable | experimental | provisional | stable | frozen
+Stability   :  unstable
 Portability :  portable | non-portable (<reason>)
 
 -}
@@ -14,41 +14,4 @@ Portability :  portable | non-portable (<reason>)
 
 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 =
+-- TODO

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 ()

src/Guide/Types/AccessToken.hs

@@ -5,7 +5,7 @@ Copyright   :  (c) Aaron Friel
 License     :  BSD-3
 
 Maintainer  :  Aaron Friel <mayreply@aaronfriel.com>
-Stability   :  unstable | experimental | provisional | stable | frozen
+Stability   :  unstable
 Portability :  portable | non-portable (<reason>)
 
 moduleLongerDescription

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 <mayreply@aaronfriel.com>
-Stability   :  unstable | experimental | provisional | stable | frozen
+Stability   :  unstable
 Portability :  portable | non-portable (<reason>)
 
 -}
@@ -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
 

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
 

src/Guide/Views/Auth/Profile.hs

@@ -5,7 +5,7 @@ Copyright   :  (c) Aaron Friel
 License     :  BSD-3
 
 Maintainer  :  Aaron Friel <mayreply@aaronfriel.com>
-Stability   :  unstable | experimental | provisional | stable | frozen
+Stability   :  unstable
 Portability :  portable | non-portable (<reason>)
 
 Should display the user's current information, any available options for changing,