Initial release (1.90.0)1.90.0

3 files changed, 200 insertions, 0 deletions

diff --git a/src/Sproxy/Application/OAuth2/Common.hs b/src/Sproxy/Application/OAuth2/Common.hs
new file mode 100644
index 0000000..07fb759
--- /dev/null
+++ b/src/Sproxy/Application/OAuth2/Common.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Sproxy.Application.OAuth2.Common (
+  AccessTokenBody(..)
+, OAuth2Client(..)
+, OAuth2Provider
+) where
+
+import Control.Applicative (empty)
+import Data.Aeson (FromJSON, parseJSON, Value(Object), (.:))
+import Data.ByteString(ByteString)
+
+import Sproxy.Application.Cookie (AuthUser)
+
+data OAuth2Client = OAuth2Client {
+  oauth2Description :: String
+, oauth2AuthorizeURL
+    :: ByteString -- state
+    -> ByteString -- redirect url
+    -> ByteString
+, oauth2Authenticate
+    :: ByteString -- code
+    -> ByteString -- redirect url
+    -> IO AuthUser
+}
+
+type OAuth2Provider = (ByteString, ByteString) -> OAuth2Client
+
+-- | RFC6749. We ignore optional token_type ("Bearer" from Google, omitted by LinkedIn)
+--   and expires_in because we don't use them, *and* expires_in creates troubles:
+--   it's an integer from Google and string from LinkedIn (sic!)
+data AccessTokenBody = AccessTokenBody {
+  accessToken :: String
+} deriving (Eq, Show)
+
+instance FromJSON AccessTokenBody where
+  parseJSON (Object v) = AccessTokenBody
+    <$> v .:  "access_token"
+  parseJSON _ = empty
+
diff --git a/src/Sproxy/Application/OAuth2/Google.hs b/src/Sproxy/Application/OAuth2/Google.hs
new file mode 100644
index 0000000..6b68f44
--- /dev/null
+++ b/src/Sproxy/Application/OAuth2/Google.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Sproxy.Application.OAuth2.Google (
+  provider
+) where
+
+import Control.Applicative (empty)
+import Control.Exception (Exception, throwIO)
+import Data.Aeson (FromJSON, decode, parseJSON, Value(Object), (.:))
+import Data.ByteString.Lazy (ByteString)
+import Data.Monoid ((<>))
+import Data.Typeable (Typeable)
+import Network.HTTP.Types (hContentType)
+import Network.HTTP.Types.URI (urlEncode)
+import qualified Network.HTTP.Conduit as H
+
+import Sproxy.Application.Cookie (AuthUser(..))
+import Sproxy.Application.OAuth2.Common (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider)
+
+
+provider :: OAuth2Provider
+provider (client_id, client_secret) =
+  OAuth2Client {
+    oauth2Description = "Google"
+  , oauth2AuthorizeURL = \state redirect_uri ->
+         "https://accounts.google.com/o/oauth2/v2/auth"
+      <> "?scope=" <> urlEncode True "https://www.googleapis.com/auth/userinfo.email https://www.googleapis.com/auth/userinfo.profile"
+      <> "&client_id=" <> urlEncode True client_id
+      <> "&prompt=select_account"
+      <> "&redirect_uri=" <> urlEncode True redirect_uri
+      <> "&response_type=code"
+      <> "&state=" <> urlEncode True state
+
+  , oauth2Authenticate = \code redirect_uri -> do
+      let treq = H.setQueryString [
+                ("client_id"     , Just client_id)
+              , ("client_secret" , Just client_secret)
+              , ("code"          , Just code)
+              , ("grant_type"    , Just "authorization_code")
+              , ("redirect_uri"  , Just redirect_uri)
+              ] $ (H.parseRequest_ "POST https://www.googleapis.com/oauth2/v4/token") {
+                H.requestHeaders = [
+                  (hContentType, "application/x-www-form-urlencoded")
+                ]
+              }
+      mgr   <- H.newManager H.tlsManagerSettings
+      tresp <- H.httpLbs treq mgr
+      case decode $ H.responseBody tresp of
+        Nothing -> throwIO $ GoogleException tresp
+        Just atResp -> do
+          ureq  <- H.parseRequest $ "https://www.googleapis.com/oauth2/v1/userinfo?access_token=" ++ accessToken atResp
+          uresp <- H.httpLbs ureq mgr
+          case decode $ H.responseBody uresp of
+            Nothing -> throwIO $ GoogleException uresp
+            Just u -> return AuthUser { auEmail = email u, auGivenName = givenName u, auFamilyName = familyName u }
+  }
+
+
+data GoogleException = GoogleException (H.Response ByteString)
+  deriving (Show, Typeable)
+
+
+instance Exception GoogleException
+
+
+data GoogleUserInfo = GoogleUserInfo {
+  email :: String
+, givenName :: String
+, familyName :: String
+} deriving (Eq, Show)
+
+instance FromJSON GoogleUserInfo where
+  parseJSON (Object v) = GoogleUserInfo
+    <$> v .: "email"
+    <*> v .: "given_name"
+    <*> v .: "family_name"
+  parseJSON _ = empty
+
diff --git a/src/Sproxy/Application/OAuth2/LinkedIn.hs b/src/Sproxy/Application/OAuth2/LinkedIn.hs
new file mode 100644
index 0000000..b60afde
--- /dev/null
+++ b/src/Sproxy/Application/OAuth2/LinkedIn.hs
@@ -0,0 +1,83 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Sproxy.Application.OAuth2.LinkedIn (
+  provider
+) where
+
+import Control.Applicative (empty)
+import Control.Exception (Exception, throwIO)
+import Data.Aeson (FromJSON, decode, parseJSON, Value(Object), (.:))
+import Data.ByteString.Char8 (pack)
+import Data.ByteString.Lazy (ByteString)
+import Data.Monoid ((<>))
+import Data.Typeable (Typeable)
+import Network.HTTP.Types (hContentType)
+import Network.HTTP.Types.URI (urlEncode)
+import qualified Network.HTTP.Conduit as H
+
+import Sproxy.Application.Cookie (AuthUser(..))
+import Sproxy.Application.OAuth2.Common (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider)
+
+
+provider :: OAuth2Provider
+provider (client_id, client_secret) =
+  OAuth2Client {
+    oauth2Description = "LinkedIn"
+  , oauth2AuthorizeURL = \state redirect_uri ->
+         "https://www.linkedin.com/oauth/v2/authorization"
+      <> "?scope=r_basicprofile%20r_emailaddress"
+      <> "&client_id=" <> urlEncode True client_id
+      <> "&redirect_uri=" <> urlEncode True redirect_uri
+      <> "&response_type=code"
+      <> "&state=" <> urlEncode True state
+
+  , oauth2Authenticate = \code redirect_uri -> do
+      let treq = H.setQueryString [
+                ("client_id"     , Just client_id)
+              , ("client_secret" , Just client_secret)
+              , ("code"          , Just code)
+              , ("grant_type"    , Just "authorization_code")
+              , ("redirect_uri"  , Just redirect_uri)
+              ] $ (H.parseRequest_ "POST https://www.linkedin.com/oauth/v2/accessToken") {
+                H.requestHeaders = [
+                  (hContentType, "application/x-www-form-urlencoded")
+                ]
+              }
+      mgr   <- H.newManager H.tlsManagerSettings
+      tresp <- H.httpLbs treq mgr
+      case decode $ H.responseBody tresp of
+        Nothing -> throwIO $ LinkedInException tresp
+        Just atResp -> do
+          let ureq = (H.parseRequest_ "https://api.linkedin.com/v1/people/\
+                \~:(email-address,first-name,last-name)?format=json") {
+                  H.requestHeaders = [ ("Authorization", "Bearer " <> pack (accessToken atResp)) ]
+                }
+          uresp <- H.httpLbs ureq mgr
+          case decode $ H.responseBody uresp of
+            Nothing -> throwIO $ LinkedInException uresp
+            Just u -> return AuthUser { auEmail = emailAddress u
+                                      , auGivenName = firstName u
+                                      , auFamilyName = lastName u }
+  }
+
+
+data LinkedInException = LinkedInException (H.Response ByteString)
+  deriving (Show, Typeable)
+
+
+instance Exception LinkedInException
+
+
+data LinkedInUserInfo = LinkedInUserInfo {
+  emailAddress :: String
+, firstName :: String
+, lastName :: String
+} deriving (Eq, Show)
+
+instance FromJSON LinkedInUserInfo where
+  parseJSON (Object v) = LinkedInUserInfo
+    <$> v .: "emailAddress"
+    <*> v .: "firstName"
+    <*> v .: "lastName"
+  parseJSON _ = empty
+