aboutsummaryrefslogtreecommitdiff
path: root/src/Sproxy/Application
diff options
context:
space:
mode:
Diffstat (limited to 'src/Sproxy/Application')
-rw-r--r--src/Sproxy/Application/Cookie.hs44
-rw-r--r--src/Sproxy/Application/OAuth2.hs18
-rw-r--r--src/Sproxy/Application/OAuth2/Common.hs39
-rw-r--r--src/Sproxy/Application/OAuth2/Google.hs78
-rw-r--r--src/Sproxy/Application/OAuth2/LinkedIn.hs83
-rw-r--r--src/Sproxy/Application/State.hs30
6 files changed, 292 insertions, 0 deletions
diff --git a/src/Sproxy/Application/Cookie.hs b/src/Sproxy/Application/Cookie.hs
new file mode 100644
index 0000000..07cc162
--- /dev/null
+++ b/src/Sproxy/Application/Cookie.hs
@@ -0,0 +1,44 @@
+module Sproxy.Application.Cookie (
+ AuthCookie(..)
+, AuthUser(..)
+, cookieDecode
+, cookieEncode
+) where
+
+import Data.ByteString (ByteString)
+import Foreign.C.Types (CTime(..))
+import qualified Data.Serialize as DS
+
+import qualified Sproxy.Application.State as State
+
+data AuthUser = AuthUser {
+ auEmail :: String
+, auGivenName :: String
+, auFamilyName :: String
+}
+
+data AuthCookie = AuthCookie {
+ acUser :: AuthUser
+, acExpiry :: CTime
+}
+
+instance DS.Serialize AuthCookie where
+ put c = DS.put (auEmail u, auGivenName u, auFamilyName u, x)
+ where u = acUser c
+ x = (\(CTime i) -> i) $ acExpiry c
+ get = do
+ (e, n, f, x) <- DS.get
+ return AuthCookie {
+ acUser = AuthUser { auEmail = e, auGivenName = n, auFamilyName = f }
+ , acExpiry = CTime x
+ }
+
+
+cookieDecode :: ByteString -> ByteString -> Either String AuthCookie
+cookieDecode key d = State.decode key d >>= DS.decode
+
+
+cookieEncode :: ByteString -> AuthCookie -> ByteString
+cookieEncode key = State.encode key . DS.encode
+
+
diff --git a/src/Sproxy/Application/OAuth2.hs b/src/Sproxy/Application/OAuth2.hs
new file mode 100644
index 0000000..0f7d6e8
--- /dev/null
+++ b/src/Sproxy/Application/OAuth2.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Sproxy.Application.OAuth2 (
+ providers
+) where
+
+import Data.HashMap.Strict (HashMap, fromList)
+import Data.Text (Text)
+
+import Sproxy.Application.OAuth2.Common (OAuth2Provider)
+import qualified Sproxy.Application.OAuth2.Google as Google
+import qualified Sproxy.Application.OAuth2.LinkedIn as LinkedIn
+
+providers :: HashMap Text OAuth2Provider
+providers = fromList [
+ ("google" , Google.provider)
+ , ("linkedin" , LinkedIn.provider)
+ ]
+
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
+
diff --git a/src/Sproxy/Application/State.hs b/src/Sproxy/Application/State.hs
new file mode 100644
index 0000000..29d9252
--- /dev/null
+++ b/src/Sproxy/Application/State.hs
@@ -0,0 +1,30 @@
+module Sproxy.Application.State (
+ decode
+, encode
+) where
+
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy (fromStrict, toStrict)
+import Data.Digest.Pure.SHA (hmacSha1, bytestringDigest)
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.Serialize as DS
+
+
+-- FIXME: Compress / decompress ?
+
+
+encode :: ByteString -> ByteString -> ByteString
+encode key payload = Base64.encode . DS.encode $ (payload, digest key payload)
+
+
+decode :: ByteString -> ByteString -> Either String ByteString
+decode key d = do
+ (payload, dgst) <- DS.decode =<< Base64.decode d
+ if dgst /= digest key payload
+ then Left "junk"
+ else Right payload
+
+
+digest :: ByteString -> ByteString -> ByteString
+digest key payload = toStrict . bytestringDigest $ hmacSha1 (fromStrict key) (fromStrict payload)
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-15 05:26:55 +0000