aboutsummaryrefslogtreecommitdiff
path: root/src/Sproxy
diff options
context:
space:
mode:
Diffstat (limited to 'src/Sproxy')
-rw-r--r--src/Sproxy/Application.hs48
-rw-r--r--src/Sproxy/Application/Cookie.hs45
-rw-r--r--src/Sproxy/Application/OAuth2/Common.hs3
-rw-r--r--src/Sproxy/Application/OAuth2/Google.hs15
-rw-r--r--src/Sproxy/Application/OAuth2/LinkedIn.hs19
-rw-r--r--src/Sproxy/Server/DB.hs8
6 files changed, 90 insertions, 48 deletions
diff --git a/src/Sproxy/Application.hs b/src/Sproxy/Application.hs
index 83c4b70..ad3bec7 100644
--- a/src/Sproxy/Application.hs
+++ b/src/Sproxy/Application.hs
@@ -11,7 +11,6 @@ import Blaze.ByteString.Builder.ByteString (fromByteString)
import Control.Exception (Exception, Handler(..), SomeException, catches, displayException)
import Data.ByteString (ByteString)
import Data.ByteString as BS (break, intercalate)
-import Data.Char (toLower)
import Data.ByteString.Char8 (pack, unpack)
import Data.ByteString.Lazy (fromStrict)
import Data.Conduit (Flush(Chunk), mapOutput)
@@ -44,7 +43,9 @@ import qualified Network.HTTP.Client as BE
import qualified Network.Wai as W
import qualified Web.Cookie as WC
-import Sproxy.Application.Cookie (AuthCookie(..), AuthUser(..), cookieDecode, cookieEncode)
+import Sproxy.Application.Cookie ( AuthCookie(..), AuthUser,
+ cookieDecode, cookieEncode, getEmail, getEmailUtf8, getFamilyNameUtf8,
+ getGivenNameUtf8 )
import Sproxy.Application.OAuth2.Common (OAuth2Client(..))
import Sproxy.Config(BackendConf(..))
import Sproxy.Server.DB (Database, userExists, userGroups)
@@ -115,11 +116,11 @@ oauth2callback key db (provider, oa2c) be req resp =
Left msg -> badRequest ("invalid state: " ++ msg) req resp
Right path -> do
au <- oauth2Authenticate oa2c code (redirectURL req provider)
- let email = map toLower $ auEmail au
- Log.info $ "login `" ++ email ++ "' by " ++ show provider
+ let email = getEmail au
+ Log.info $ "login " ++ show email ++ " by " ++ show provider
exists <- userExists db email
- if exists then authenticate key be au{auEmail = email} path req resp
- else userNotFound email req resp
+ if exists then authenticate key be au path req resp
+ else userNotFound au req resp
where
param p = do
(_, v) <- find ((==) p . fst) $ W.queryString req
@@ -166,29 +167,31 @@ authenticate key be user path req resp = do
authorize :: Database -> (AuthCookie, Cookies) -> W.Request -> IO (Maybe W.Request)
authorize db (authCookie, otherCookies) req = do
+ let
+ user = acUser authCookie
+ domain = decodeUtf8 . fromJust $ W.requestHeaderHost req
+ email = getEmail user
+ emailUtf8 = getEmailUtf8 user
+ familyUtf8 = getFamilyNameUtf8 user
+ givenUtf8 = getGivenNameUtf8 user
+ method = decodeUtf8 $ W.requestMethod req
+ path = decodeUtf8 $ W.rawPathInfo req
grps <- userGroups db email domain path method
if null grps then return Nothing
else do
ip <- pack . fromJust . fst <$> getNameInfo [NI_NUMERICHOST] True False (W.remoteHost req)
return . Just $ req {
W.requestHeaders = toList $
- insert "From" (pack email) $
- insert "X-Groups" (BS.intercalate "," grps) $
- insert "X-Given-Name" given $
- insert "X-Family-Name" family $
+ insert "From" emailUtf8 $
+ insert "X-Groups" (BS.intercalate "," $ encodeUtf8 <$> grps) $
+ insert "X-Given-Name" givenUtf8 $
+ insert "X-Family-Name" familyUtf8 $
insert "X-Forwarded-Proto" "https" $
insertWith (flip combine) "X-Forwarded-For" ip $
setCookies otherCookies $
fromListWith combine $ W.requestHeaders req
}
where
- user = acUser authCookie
- email = auEmail user
- given = pack $ auGivenName user
- family = pack $ auFamilyName user
- domain = decodeUtf8 . fromJust $ W.requestHeaderHost req
- path = decodeUtf8 $ W.rawPathInfo req
- method = decodeUtf8 $ W.requestMethod req
combine a b = a <> "," <> b
setCookies [] = delete hCookie
setCookies cs = insert hCookie (toByteString . renderCookies $ cs)
@@ -278,10 +281,10 @@ authenticationRequired key oa2 req resp = do
forbidden :: AuthCookie -> W.Application
forbidden ac req resp = do
- Log.info $ "403 Forbidden (" ++ email ++ "): " ++ showReq req
+ Log.info $ "403 Forbidden: " ++ show email ++ ": " ++ showReq req
resp $ W.responseLBS forbidden403 [(hContentType, "text/html; charset=utf-8")] page
where
- email = auEmail . acUser $ ac
+ email = getEmailUtf8 . acUser $ ac
page = fromStrict [qc|
<!DOCTYPE html>
<html lang="en">
@@ -298,11 +301,12 @@ forbidden ac req resp = do
|]
-userNotFound :: String -> W.Application
-userNotFound email _ resp = do
- Log.info $ "404 User not found (" ++ email ++ ")"
+userNotFound :: AuthUser -> W.Application
+userNotFound au _ resp = do
+ Log.info $ "404 User not found: " ++ show email
resp $ W.responseLBS notFound404 [(hContentType, "text/html; charset=utf-8")] page
where
+ email = getEmailUtf8 au
page = fromStrict [qc|
<!DOCTYPE html>
<html lang="en">
diff --git a/src/Sproxy/Application/Cookie.hs b/src/Sproxy/Application/Cookie.hs
index 07cc162..a86f42a 100644
--- a/src/Sproxy/Application/Cookie.hs
+++ b/src/Sproxy/Application/Cookie.hs
@@ -1,20 +1,30 @@
+{-# LANGUAGE OverloadedStrings #-}
module Sproxy.Application.Cookie (
AuthCookie(..)
-, AuthUser(..)
+, AuthUser
, cookieDecode
, cookieEncode
+, getEmail
+, getEmailUtf8
+, getFamilyNameUtf8
+, getGivenNameUtf8
+, newUser
+, setFamilyName
+, setGivenName
) where
import Data.ByteString (ByteString)
+import Data.Text (Text, toLower, strip)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
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
+ auEmail :: ByteString
+, auGivenName :: ByteString
+, auFamilyName :: ByteString
}
data AuthCookie = AuthCookie {
@@ -37,8 +47,33 @@ instance DS.Serialize AuthCookie where
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
+getEmail :: AuthUser -> Text
+getEmail = decodeUtf8 . auEmail
+
+getEmailUtf8 :: AuthUser -> ByteString
+getEmailUtf8 = auEmail
+
+getGivenNameUtf8 :: AuthUser -> ByteString
+getGivenNameUtf8 = auGivenName
+
+getFamilyNameUtf8 :: AuthUser -> ByteString
+getFamilyNameUtf8 = auFamilyName
+
+
+newUser :: Text -> AuthUser
+newUser email = AuthUser {
+ auEmail = encodeUtf8 . toLower . strip $ email
+ , auGivenName = ""
+ , auFamilyName = ""
+ }
+
+setGivenName :: Text -> AuthUser -> AuthUser
+setGivenName given au = au{ auGivenName = encodeUtf8 . strip $ given }
+
+setFamilyName :: Text -> AuthUser -> AuthUser
+setFamilyName family au = au{ auFamilyName = encodeUtf8 . strip $ family }
+
diff --git a/src/Sproxy/Application/OAuth2/Common.hs b/src/Sproxy/Application/OAuth2/Common.hs
index 07fb759..0324e62 100644
--- a/src/Sproxy/Application/OAuth2/Common.hs
+++ b/src/Sproxy/Application/OAuth2/Common.hs
@@ -8,6 +8,7 @@ module Sproxy.Application.OAuth2.Common (
import Control.Applicative (empty)
import Data.Aeson (FromJSON, parseJSON, Value(Object), (.:))
import Data.ByteString(ByteString)
+import Data.Text (Text)
import Sproxy.Application.Cookie (AuthUser)
@@ -29,7 +30,7 @@ type OAuth2Provider = (ByteString, ByteString) -> OAuth2Client
-- 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
+ accessToken :: Text
} deriving (Eq, Show)
instance FromJSON AccessTokenBody where
diff --git a/src/Sproxy/Application/OAuth2/Google.hs b/src/Sproxy/Application/OAuth2/Google.hs
index 6b68f44..5a1834c 100644
--- a/src/Sproxy/Application/OAuth2/Google.hs
+++ b/src/Sproxy/Application/OAuth2/Google.hs
@@ -9,12 +9,13 @@ import Control.Exception (Exception, throwIO)
import Data.Aeson (FromJSON, decode, parseJSON, Value(Object), (.:))
import Data.ByteString.Lazy (ByteString)
import Data.Monoid ((<>))
+import Data.Text (Text, unpack)
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.Cookie (newUser, setFamilyName, setGivenName)
import Sproxy.Application.OAuth2.Common (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider)
@@ -48,11 +49,13 @@ provider (client_id, client_secret) =
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
+ ureq <- H.parseRequest $ unpack ("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 }
+ Just u -> return $ setFamilyName (familyName u) $
+ setGivenName (givenName u) $
+ newUser (email u)
}
@@ -64,9 +67,9 @@ instance Exception GoogleException
data GoogleUserInfo = GoogleUserInfo {
- email :: String
-, givenName :: String
-, familyName :: String
+ email :: Text
+, givenName :: Text
+, familyName :: Text
} deriving (Eq, Show)
instance FromJSON GoogleUserInfo where
diff --git a/src/Sproxy/Application/OAuth2/LinkedIn.hs b/src/Sproxy/Application/OAuth2/LinkedIn.hs
index b60afde..b35c566 100644
--- a/src/Sproxy/Application/OAuth2/LinkedIn.hs
+++ b/src/Sproxy/Application/OAuth2/LinkedIn.hs
@@ -7,15 +7,16 @@ module Sproxy.Application.OAuth2.LinkedIn (
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.Text (Text)
+import Data.Text.Encoding (encodeUtf8)
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.Cookie (newUser, setFamilyName, setGivenName)
import Sproxy.Application.OAuth2.Common (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider)
@@ -50,14 +51,14 @@ provider (client_id, client_secret) =
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)) ]
+ H.requestHeaders = [ ("Authorization", "Bearer " <> encodeUtf8 (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 }
+ Just u -> return $ setFamilyName (lastName u) $
+ setGivenName (firstName u) $
+ newUser (emailAddress u)
}
@@ -69,9 +70,9 @@ instance Exception LinkedInException
data LinkedInUserInfo = LinkedInUserInfo {
- emailAddress :: String
-, firstName :: String
-, lastName :: String
+ emailAddress :: Text
+, firstName :: Text
+, lastName :: Text
} deriving (Eq, Show)
instance FromJSON LinkedInUserInfo where
diff --git a/src/Sproxy/Server/DB.hs b/src/Sproxy/Server/DB.hs
index b760afc..90e2abd 100644
--- a/src/Sproxy/Server/DB.hs
+++ b/src/Sproxy/Server/DB.hs
@@ -11,11 +11,9 @@ module Sproxy.Server.DB (
import Control.Concurrent (forkIO, threadDelay)
import Control.Exception (SomeException, bracket, catch, finally)
import Control.Monad (forever, void)
-import Data.ByteString (ByteString)
import Data.ByteString.Char8 (pack)
import Data.Pool (Pool, createPool, withResource)
import Data.Text (Text, toLower, unpack)
-import Data.Text.Encoding (encodeUtf8)
import Database.SQLite.Simple (NamedParam((:=)))
import Text.InterpolatedString.Perl6 (q, qc)
import qualified Database.PostgreSQL.Simple as PG
@@ -52,7 +50,7 @@ start home ds = do
return db
-userExists :: Database -> String -> IO Bool
+userExists :: Database -> Text -> IO Bool
userExists db email = do
r <- withResource db $ \c -> fmap SQLite.fromOnly <$> SQLite.queryNamed c
"SELECT EXISTS (SELECT 1 FROM group_member WHERE :email LIKE email LIMIT 1)"
@@ -60,9 +58,9 @@ userExists db email = do
return $ head r
-userGroups :: Database -> String -> Text -> Text -> Text -> IO [ByteString]
+userGroups :: Database -> Text -> Text -> Text -> Text -> IO [Text]
userGroups db email domain path method =
- withResource db $ \c -> fmap (encodeUtf8 . SQLite.fromOnly) <$> SQLite.queryNamed c [q|
+ withResource db $ \c -> fmap SQLite.fromOnly <$> SQLite.queryNamed c [q|
SELECT gm."group" FROM group_privilege gp JOIN group_member gm ON gm."group" = gp."group"
WHERE :email LIKE gm.email
AND :domain LIKE gp.domain
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-01 00:01:30 +0000