sproxy (empty) → 0.9.4

raw patch · 16 files changed

+1251/−0 lines, 16 filesdep +SHAdep +aesondep +attoparsecsetup-changed

Dependencies added: SHA, aeson, attoparsec, base, base64-bytestring, bytestring, containers, data-default, docopt, entropy, http-conduit, http-kit, http-types, interpolatedstring-perl6, logging-facade, logsink, network, postgresql-simple, raw-strings-qq, resource-pool, split, string-conversions, time, tls, unix, utf8-string, x509, yaml

Files

• ChangeLog.md +34/−0
• LICENSE +19/−0
• README.md +154/−0
• Setup.lhs +3/−0
• sproxy.cabal +60/−0
• sproxy.sql +148/−0
• src/Authenticate.hs +198/−0
• src/Authorize.hs +67/−0
• src/ConfigFile.hs +73/−0
• src/Cookies.hs +83/−0
• src/HTTP.hs +72/−0
• src/Logging.hs +6/−0
• src/Main.hs +43/−0
• src/Proxy.hs +249/−0
• src/Type.hs +5/−0
• src/Util.hs +37/−0

@@ -0,0 +1,34 @@+0.9.4+=====++* Combine the multiple header fields into one "field-name: field-value" pair+  with a comma-separated list for the field-value (Instead of removing duplicates).+* `sproxy [ -h | --help ]` works (using [docopt](https://hackage.haskell.org/package/docopt))+* Stop counting client parsing failures as errors.+++0.9.3+=====++* Made some options in configuration file optional with reasonable default values:+  - `log_target`: `stderr`+  - `listen`: `443`+  - `redirect_http_to_https`: yes if `listen == 443`+  - `backend_address`: `"127.0.0.1"`+  - `backend_port`: `8080`+* Allow backend at UNIX socket: new option `backend_socket`.+* Removed tests (unsupported).+* Don't build Sproxy library.+++0.9.2+=====++* Deny SSLv3.++* Removed the `auth_token_key` option from the config file.+  The token is generated randomly on startup.+	Restarting sproxy invalidates existing sessions.++* Added `ChangeLog.md`+

@@ -0,0 +1,19 @@+Copyright (c) 2013-2016 Zalora South East Asia Pte. Ltd++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.

@@ -0,0 +1,154 @@+# sproxy - secure proxy - HTTP proxy for authenticating users via Google OAuth2++## Motivation++Why use a proxy for doing OAuth? Isn't that up to the application?++ * sproxy is secure by default.  No requests make it to the web server if they+   haven't been explicitly whitelisted.+ * sproxy is independent.  Any web application written in any language can use+   it.++## How it Works++When an HTTP client makes a request, sproxy checks for a *session cookie*.  If it+doesn't exist (or it's invalid), it redirects the client to a Google+authentication page.  The user is then prompted to allow the application to+access information on the user (email address).  If the user proceeds, they're+redirected back to sproxy with a code from Google.  We then take that code and+send it to Google ourselves to get back an access token.  Then, we use the+access token to make another call to Google, this time to their user info API+to retrieve the user's email address.  Finally, we store the the email address+in a session cookie: signed with a hash to prevent tampering, set for HTTP only (to+prevent malicious JavaScript from reading it), and set it for secure (since we+don't want it traveling over plaintext HTTP connections).++From that point on, when sproxy detects a valid session cookie it extracts the+email, checks it against the access rules, and relays the request to the+back-end server (if allowed).++## Logout++Hitting the endpoint `/sproxy/logout` will invalidate the session+cookie.  The user will be redirected to `/` after logout.  The+query parameter `state` can be provided to specify an alternate redirect path+(the path has to be percent-encoded, e.g. with `urlEncode` from+`Network.HTTP.Types.URI`).++## Robots++Since all sproxied resources are private, it doesn't make sense for web crawlers+to try to index them. In fact, crawlers will index only the Google authentication+page. To prevent this, sproxy returns the following for `/robots.txt`:++```+User-agent: *+Disallow: /+```++## Permissions system++Permissions are stored in a PostgreSQL database. See sproxy.sql for details.+Here are the main concepts:++- A `group` is identified by a name. Every group has+  - members (identified by email address, through `group_member`) and+  - associated privileges (through `group_privilege`).+- A `privilege` is identified by a name _and_ a domain. It has associated rules+  (through `privilege_rule`) that define what the privilege gives access to.+- A `rule` is a combination of sql patterns for a `domain`, a `path` and an+  HTTP `method`. A rule matches an HTTP request, if all of these components+  match the respective attributes of the request. However of all the matching+  rules only the rule with the longest `path` pattern will be used to determine+  whether a user is allowed to perform a request. This is often a bit+  surprising, please see the following example:++### Privileges example++Consider this `group_privilege` and `privilege_rule` relations:++group            | privilege | domain+---------------- | --------- | -----------------+`readers`        | `basic`   | `wiki.zalora.com`+`readers`        | `read`    | `wiki.zalora.com`+`editors`        | `basic`   | `wiki.zalora.com`+`editors`        | `read`    | `wiki.zalora.com`+`editors`        | `edit`    | `wiki.zalora.com`+`administrators` | `basic`   | `wiki.zalora.com`+`administrators` | `read`    | `wiki.zalora.com`+`administrators` | `edit`    | `wiki.zalora.com`+`administrators` | `admin`   | `wiki.zalora.com`++privilege   | domain            | path           | method+----------- | ----------------- | -------------- | ------+`basic`     | `wiki.zalora.com` | `/%`           | `GET`+`read`      | `wiki.zalora.com` | `/wiki/%`      | `GET`+`edit`      | `wiki.zalora.com` | `/wiki/edit/%` | `%`+`admin`     | `wiki.zalora.com` | `/admin/%`     | `%`++With this setup, everybody (that is `readers`, `editors` and `administrators`s)+will have access to e.g. `/imgs/logo.png` and `/favicon.ico`, but only+administrators will have access to `/admin/index.php`, because the longest+matching path pattern is `/admin/%` and only `administrator`s have the `admin`+privilege.++Likewise `readers` have no access to e.g. `/wiki/edit/delete_everything.php`.+++## HTTP headers passed to the back-end server:++header               | value+-------------------- | -----+`From:`              | visitor's email address+`X-Groups:`          | all groups that granted access to this resource, separated by commas (see the note below)+`X-Given-Name:`      | the visitor's given (first) name+`X-Family-Name:`     | the visitor's family (last) name+`X-Forwarded-Proto:` | the visitor's protocol of an HTTP request, always `https`+`X-Forwarded-For`    | the visitor's IP address (added to the end of the list if header is already present in client request)+++`X-Groups` denotes an intersection of the groups the visitor belongs to and the groups that granted access:++Visitor's groups | Granted groups | `X-Groups`+---------------- | -------------- | ---------+all              | all, devops    | all+all, devops      | all            | all+all, devops      | all, devops    | all,devops+all, devops      | devops         | devops+devops           | all, devops    | devops+devops           | all            | Access denied++## Configuration File++By default `sproxy` will read its configuration from `config/sproxy.yml`.  You+can specify a custom path with:++```+sproxy --config /path/to/sproxy.yml+```++## Development++```+$ cp config/sproxy.yml.example config/sproxy.yml+```++Make sure that you have the following entry in `/etc/hosts`:++```+127.0.0.1       dev.zalora.com+```+++### Create OAuth credentials++Create a project in the [Google Developers Console](https://console.developers.google.com/project).++ - visit *APIs & auth* -> *Credentials*+ - select *CREATE NEW CLIENT ID*+ - use `https://dev.zalora.com` as *Authorized JavaScript origins*+ - use `https://dev.zalora.com/sproxy/oauth2callback` as *Authorized redirect URI*++Put the `Client ID` in `config/sproxy.yml` and the `Client secret` in a file+called `config/client_secret`.+

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

@@ -0,0 +1,60 @@+name: sproxy+version: 0.9.4+synopsis: HTTP proxy for authenticating users via Google OAuth2+license: MIT+license-file: LICENSE+copyright: 2013-2016, Zalora South East Asia Pte. Ltd+author: Chris Forno <jekor@jekor.com>+maintainer: Igor Pashev <pashev.igor@gmail.com>+category: Web+build-type: Simple+extra-source-files: README.md ChangeLog.md+cabal-version: >=1.10+data-files: sproxy.sql++executable sproxy+  main-is: Main.hs+  other-modules:+      Authenticate+    , Authorize+    , ConfigFile+    , Cookies+    , HTTP+    , Logging+    , Proxy+    , Type+    , Util++  hs-source-dirs: src+  default-language: Haskell2010+  ghc-options: -Wall -static+  build-depends:+      base >= 4.8 && < 5+    , SHA+    , aeson >= 0.7.0.4+    , attoparsec+    , base64-bytestring+    , bytestring+    , containers >= 0.5+    , data-default+    , docopt >= 0.7+    , entropy+    , http-conduit >= 2.1.8+    , http-kit >= 0.5+    , http-types >= 0.8.5+    , interpolatedstring-perl6+    , logging-facade+    , logsink+    , network+    , postgresql-simple+    , raw-strings-qq >= 1.1+    , resource-pool+    , split+    , string-conversions+    , time+    , tls >= 1.3.3+    , unix+    , utf8-string+    , x509+    , yaml >= 0.8+

@@ -0,0 +1,148 @@+-- CREATE DATABASE sproxy;+-- CREATE ROLE sproxy WITH LOGIN;+-- GRANT SELECT ON ALL TABLES IN SCHEMA public TO sproxy;++CREATE TABLE IF NOT EXISTS "group" (+  "group" TEXT NOT NULL PRIMARY KEY+);++-- | group        |+-- |--------------|+-- | data science |+-- | devops       |+-- | all          |+-- | regional     |+-- | SG HQ        |++CREATE EXTENSION IF NOT EXISTS citext;++CREATE TABLE IF NOT EXISTS group_member (+  "group" TEXT REFERENCES "group" ("group") ON UPDATE CASCADE ON DELETE CASCADE NOT NULL,+  email citext NOT NULL,+  PRIMARY KEY ("group", email)+);++-- | group        | email                  |+-- |--------------+------------------------|+-- | data science | blah@zalora.com        |+-- | data science | foo@zalora.com         |+-- | devops       | devops1@zalora.com     |+-- | devops       | devops2@zalora.com     |+-- | all          | %@zalora.com           |+-- | all          | %@zalora.sg            |+-- | all          | %@zalora.vn            |+-- | all          | %@zalora.com.hk        |+-- | all          | %@zalora.com.my        |+-- | all          | %@zalora.com.ph        |+-- | all          | %@zalora.co.id         |+-- | all          | %@zalora.co.th         |+-- | regional     | %@zalora.com           |+-- | SG           | %@zalora.sg            |++-- Find out which groups a user (email address) belongs to:+-- SELECT "group" FROM group_member WHERE 'email.address' LIKE email++CREATE TABLE IF NOT EXISTS domain (+  domain TEXT NOT NULL PRIMARY KEY+);++-- | domain                |+-- |-----------------------|+-- | app1.zalora.com       |+-- | app2.zalora.com       |+-- | app3.zalora.com       |++CREATE TABLE IF NOT EXISTS privilege (+  "domain" TEXT REFERENCES domain (domain) ON UPDATE CASCADE ON DELETE CASCADE NOT NULL,+  privilege TEXT NOT NULL,+  PRIMARY KEY ("domain", privilege)+);++-- | domain                | privilege  |+-- |-----------------------+------------|+-- | app3.zalora.com       | view       |+-- | app3.zalora.com       | export     |+-- | app1.zalora.com       | list users |+-- | app1.zalora.com       | add users  |++CREATE TABLE IF NOT EXISTS privilege_rule (+  "domain" TEXT NOT NULL,+  privilege TEXT NOT NULL,+  "path" TEXT NOT NULL,+  "method" TEXT NOT NULL,+  FOREIGN KEY ("domain", privilege) REFERENCES privilege ("domain", privilege) ON UPDATE CASCADE ON DELETE CASCADE,+  PRIMARY KEY ("domain", "path", "method")+);++-- | domain                | privilege  | path      | method |+-- |-----------------------+------------+-----------+--------|+-- | app3.zalora.com       | view       | /%        | %      |+-- | app3.zalora.com       | export     | /export/% | %      |+-- | app1.zalora.com       | list users | /users    | GET    |+-- | app1.zalora.com       | list users | /user/%   | GET    |+-- | app1.zalora.com       | add users  | /users    | POST   |++CREATE TABLE IF NOT EXISTS group_privilege (+  "group" TEXT REFERENCES "group" ("group") ON UPDATE CASCADE ON DELETE CASCADE NOT NULL,+  "domain" TEXT NOT NULL,+  privilege TEXT NOT NULL,+  FOREIGN KEY ("domain", privilege) REFERENCES privilege ("domain", privilege) ON UPDATE CASCADE ON DELETE CASCADE,+  PRIMARY KEY ("group", "domain", privilege)+);++-- | group        | domain                | privilege  |+-- |--------------+-----------------------+------------|+-- | data science | app3.zalora.com       | view       |+-- | data science | app3.zalora.com       | export     |+-- | all          | app1.zalora.com       | list users |+-- | devops       | app1.zalora.com       | add users  |++-- Check if the user is authorized for the request. Let's break it+-- down for understanding:++-- The privilege required to access a URL is the most specific+-- (longest) match. To determine length, we look at the number of+-- slashes in the URL pattern (number of path components).+--+-- SELECT p.privilege FROM privilege p+-- INNER JOIN privilege_rule pr ON pr."domain" = p."domain" AND pr.privilege = p.privilege+-- WHERE 'app3.zalora.com' LIKE pr."domain" AND '/export/test' LIKE "path" AND 'GET' ILIKE "method"+-- ORDER by array_length(regexp_split_to_array("path", '/'), 1) DESC LIMIT 1+--+-- To get the groups that grant the user access, put that in a subquery:+--+-- SELECT gp."group" FROM group_privilege gp+-- INNER JOIN group_member gm ON gm."group" = gp."group"+-- WHERE 'blah@zalora.com' LIKE email+-- AND 'app3.zalora.com' LIKE "domain"+-- AND privilege IN (+--   SELECT p.privilege FROM privilege p+--   INNER JOIN privilege_rule pr ON pr."domain" = p."domain" AND pr.privilege = p.privilege+--   WHERE 'app3.zalora.com' LIKE pr."domain" AND '/export/test' LIKE "path" AND 'GET' ILIKE "method"+--   ORDER by array_length(regexp_split_to_array("path", '/'), 1) DESC LIMIT 1+-- )+--+-- If you just want to know if a user has access or not, you can+-- change the first line to:+--+-- SELECT COUNT(*) > 0 FROM group_privilege gp+--+-- Note for the future: If you want to support wildcards that match+-- only a single path component (e.g. app1.zalora.com/user/:/email),+-- you could try something like:+--+-- WHERE 'url' ~ regexp_replace(url, ':', '[^/]+')+--+-- But you'd also have to escape any regexp special characters in the+-- url as well (i.e. dots).++-- Example data for development:+/*+  INSERT INTO domain (domain) VALUES ('dev.zalora.com');+  INSERT INTO "group" ("group") VALUES ('dev');+  INSERT INTO group_member ("group", email) VALUES ('dev', '%');+  INSERT INTO privilege (domain, privilege) VALUES ('dev.zalora.com', 'full');+  INSERT INTO group_privilege ("group", domain, privilege) VALUES ('dev', 'dev.zalora.com', 'full');+  INSERT INTO privilege_rule (domain, privilege, path, method) VALUES ('dev.zalora.com', 'full', '%', '%');+*/+

@@ -0,0 +1,198 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module Authenticate (+  AuthConfig(..)+, AuthToken(..)+, validAuth+, redirectForAuth+, authenticate+, logout++-- exported to silence warnings+, AccessToken(..)+) where++import           Control.Applicative+import           Control.Exception+import           Text.Read (readMaybe)+import           Data.Monoid+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.UTF8 as UTF8+import qualified Data.ByteString.Lazy.Char8 as BL8+import           Data.String.Conversions (cs)+import           Data.List.Split (splitOn)+import           Data.Aeson+import           Network.HTTP.Types+import           System.Posix.Types (EpochTime)+import           System.Posix.Time (epochTime)+import           Data.Digest.Pure.SHA (hmacSha1, showDigest)+import           Network.HTTP.Conduit (simpleHttp, parseUrl, httpLbs, RequestBody(..))+import qualified Network.HTTP.Conduit as HTTP+import           Network.HTTP.Toolkit++import qualified System.Logging.Facade as Log++import           Cookies+import           HTTP++data AuthConfig = AuthConfig {+  authConfigCookieDomain :: String+, authConfigCookieName :: String+, authConfigClientID :: String+, authConfigClientSecret :: String+, authConfigAuthTokenKey :: String+} deriving (Eq, Show)++data AccessToken = AccessToken {+  accessToken :: String+, expiresIn :: Integer+, tokenType :: String+} deriving (Eq, Show)++instance FromJSON AccessToken where+  parseJSON (Object v) = AccessToken+    <$> v .: "access_token"+    <*> v .: "expires_in"+    <*> v .: "token_type"+  parseJSON _ = empty++data AuthToken = AuthToken {+  authEmail  :: String+, authName   :: (String, String)+, authExpiry :: EpochTime+, authDigest :: String -- HMAC hash+}++-- Here is the format of the actual cookie we send to the client.+instance Show AuthToken where+  show a = authEmail a ++ ":" ++ authNameString (authName a) ++ ":" ++ show (authExpiry a) ++ ":" ++ authDigest a+    where authNameString (given, family) = given ++ ":" ++ family++instance Read AuthToken where+  readsPrec _ s = case splitOn ":" s of+    [email, given, family, expire, digest] -> [(AuthToken email (given, family) (read expire) digest, "")]+    _ -> []++data UserInfo = UserInfo {+  userEmail :: String+, userGivenName :: String+, userFamilyName :: String+} deriving (Eq, Show)++instance FromJSON UserInfo where+  parseJSON (Object v) = UserInfo+    <$> v .: "email"+    <*> v .: "given_name"+    <*> v .: "family_name"+  parseJSON _ = empty++redirectUri :: ByteString -> ByteString+redirectUri baseUri = baseUri <> "/sproxy/oauth2callback"++authUrl :: ByteString -> ByteString -> AuthConfig -> ByteString+authUrl path baseUri c = mconcat [+    "https://accounts.google.com/o/oauth2/auth?scope=https%3A%2F%2Fwww.googleapis.com%2Fauth%2Fuserinfo.email+https%3A%2F%2Fwww.googleapis.com%2Fauth%2Fuserinfo.profile&"+  , "state=", urlEncode True path+  , "&redirect_uri=", redirectUri baseUri+  , "&response_type=code&client_id=", B8.pack (authConfigClientID c)+  , "&approval_prompt=force&access_type=offline"+  ]++redirectForAuth :: AuthConfig -> ByteString -> ByteString -> IO (Response BodyReader)+redirectForAuth c path baseUri = mkResponse found302 [("Location", authUrl path baseUri c)] ""++authenticate :: AuthConfig -> ByteString -> ByteString -> ByteString -> IO (Response BodyReader)+authenticate config baseUri path code = do+  Log.info ("authentication request with code " ++ show code)+  tokenRes <- try $ post "https://accounts.google.com/o/oauth2/token"+              (cs $ "code=" ++ cs code ++ "&client_id=" ++ clientID+                ++ "&client_secret=" ++ clientSecret ++ "&redirect_uri="+                ++ cs (redirectUri baseUri) ++ "&grant_type=authorization_code")+  case tokenRes of+    Left err -> authenticationFailed ("error while authenticating: " ++ show (err :: HTTP.HttpException))+    Right resp ->+      case decode (HTTP.responseBody resp) of+        Nothing ->+          authenticationFailed "Received an invalid response from Google's authentication server."+        Just token -> do+          infoRes <- try $ simpleHttp ("https://www.googleapis.com/oauth2/v1/userinfo?access_token=" ++ accessToken token)+          case infoRes of+            Left err -> authenticationFailed ("error while retrieving user info: " ++ show (err :: HTTP.HttpException))+            Right body ->+              case decode body of+                Nothing -> authenticationFailed "Received an invalid user info response from Google's authentication server."+                Just userInfo -> do+                  clientToken <- authToken authTokenKey (userEmail userInfo) (userGivenName userInfo, userFamilyName userInfo)+                  let cookie = setCookie cookieDomain cookieName (show clientToken) authShelfLife+                  mkResponse found302 [("Location", baseUri <> urlDecode False path), ("Set-Cookie", UTF8.fromString cookie)] ""+  where+    cookieDomain = authConfigCookieDomain config+    cookieName = authConfigCookieName config+    clientID = authConfigClientID config+    clientSecret = authConfigClientSecret config+    authTokenKey = authConfigAuthTokenKey config++logout :: AuthConfig -> ByteString -> IO (Response BodyReader)+logout config url = do+  let cookie = invalidateCookie cookieDomain cookieName+  mkResponse found302 [("Location", url), ("Set-Cookie", UTF8.fromString cookie)] ""+  where+    cookieDomain = authConfigCookieDomain config+    cookieName = authConfigCookieName config++post :: String -> ByteString -> IO (HTTP.Response BL8.ByteString)+post url body = do+  r' <- parseUrl url+  let r = r' { HTTP.method = "POST"+             , HTTP.requestBody = RequestBodyBS body+             , HTTP.requestHeaders+               = [ ("Content-Type" , "application/x-www-form-urlencoded")+                 ]+             }+  manager <- HTTP.newManager HTTP.tlsManagerSettings+  httpLbs r manager++validAuth :: AuthConfig -> String -> IO (Maybe AuthToken)+validAuth config token =+  case readMaybe token of+    Nothing -> return Nothing+    Just t -> do+      now <- epochTime+      if tokenDigest key t == authDigest t && authExpiry t > now+        then return $ Just t+        else return Nothing+  where+    key = authConfigAuthTokenKey config++-- | Create an AuthToken with the default expiration time, automatically+-- calculating the digest.+authToken :: String -> String -> (String, String) -> IO AuthToken+authToken key email name = do+  now <- epochTime+  let expires = now + authShelfLife+      digest = tokenDigest key AuthToken {+          authEmail = email+        , authName = name+        , authExpiry = expires+        , authDigest = ""+        }+      token = AuthToken {+          authEmail  = email+        , authName = name+        , authExpiry = expires+        , authDigest = digest+        }+  return token++-- | This generates the HMAC digest of the auth token using SHA1.+-- Eventually, we need to rotate the key used to generate the HMAC, while still+-- storing old keys long enough to use them for any valid login session. Without+-- this, authentication is less secure.+tokenDigest :: String -> AuthToken -> String+tokenDigest key a = showDigest $ hmacSha1 (BL8.pack key) (BL8.pack token)+  where token = show (authEmail a) ++ show (authExpiry a)++authShelfLife :: EpochTime+authShelfLife = 30 * 24 * 60 * 60 -- 30 days

@@ -0,0 +1,67 @@+{-# LANGUAGE QuasiQuotes #-}+module Authorize (+  AuthorizeAction+, Email+, Domain+, RequestPath+, Group++, withDatabaseAuthorizeAction+) where++import           Control.Exception+import           Data.ByteString (ByteString)+import           Network.HTTP.Types+import           Text.InterpolatedString.Perl6 (q)+import           Database.PostgreSQL.Simple+import           Data.Pool+import           Data.Time.Clock+import           Data.String.Conversions (cs)++type AuthorizeAction = Email -> Domain -> RequestPath -> Method -> IO [Group]++type Email = String+type Domain = ByteString+type RequestPath = ByteString+type Group = String++type ConnectionPool = Pool Connection++createConnectionPool :: String -> IO ConnectionPool+createConnectionPool database = createPool open close 1 connectionIdleTime connectionPoolSize+  where+    open :: IO Connection+    open = connectPostgreSQL (cs database)++    connectionPoolSize :: Int+    connectionPoolSize = 5++    connectionIdleTime :: NominalDiffTime+    connectionIdleTime = 5++destroyConnectionPool :: ConnectionPool -> IO ()+destroyConnectionPool = destroyAllResources++withConnectionPool :: String -> (ConnectionPool -> IO a) -> IO a+withConnectionPool database = bracket (createConnectionPool database) destroyConnectionPool++withDatabaseAuthorizeAction :: String -> (AuthorizeAction -> IO a) -> IO a+withDatabaseAuthorizeAction database action = withConnectionPool database $ \pool -> do+  let authorizeAction :: AuthorizeAction+      authorizeAction domain email path method = withResource pool $ \conn -> authorizedGroups conn domain email path method+  action authorizeAction++authorizedGroups :: Connection -> AuthorizeAction+authorizedGroups db email domain path method =+  fmap fromOnly `fmap` query db [q|+SELECT gp."group" FROM group_privilege gp+INNER JOIN group_member gm ON gm."group" = gp."group"+WHERE ? LIKE email+AND ? LIKE "domain"+AND privilege IN (+  SELECT p.privilege FROM privilege p+  INNER JOIN privilege_rule pr ON pr."domain" = p."domain" AND pr.privilege = p.privilege+  WHERE ? LIKE pr."domain" AND ? LIKE "path" AND ? ILIKE "method"+  ORDER by array_length(regexp_split_to_array("path", '/'), 1) DESC LIMIT 1+)+|] (email, domain, domain, path, method)

@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module ConfigFile where++import           Control.Applicative+import           Data.Char+import           Data.Word+import           Text.Read+import           System.IO+import           System.Exit+import           Data.Aeson+import           Data.Yaml+import           System.Logging.LogSink.Config++withConfigFile :: FilePath -> (ConfigFile -> IO a) -> IO a+withConfigFile configFile action = do+  c <- decodeFileEither configFile+  case c of+    Left err -> do+      hPutStrLn stderr ("error parsing configuration file " ++ configFile ++ ": " ++ show err)+      exitFailure+    Right config -> action config++data ConfigFile = ConfigFile {+  cfLogLevel :: LogLevel+, cfLogTarget :: LogTarget+, cfListen :: Word16+, cfRedirectHttpToHttps :: Maybe Bool+, cfCookieDomain :: String+, cfCookieName :: String+, cfClientID :: String+, cfClientSecretFile :: FilePath+, cfSslKey :: FilePath+, cfSslCerts :: FilePath+, cfDatabase :: String+, cfBackendAddress :: String+, cfBackendPort :: Word16+, cfBackendSocket :: Maybe String+} deriving (Eq, Show)++instance FromJSON ConfigFile where+  parseJSON (Object m) = ConfigFile <$>+        (m .: "log_level" >>= parseLogLevel)+    <*> (m .:? "log_target" .!= "stderr" >>= parseLogTarget)+    <*> m .:? "listen" .!= 443+    <*> m .:? "redirect_http_to_https"+    <*> m .: "cookie_domain"+    <*> m .: "cookie_name"+    <*> m .: "client_id"+    <*> m .: "client_secret"+    <*> m .: "ssl_key"+    <*> m .: "ssl_certs"+    <*> m .: "database"+    <*> m .:? "backend_address" .!= "127.0.0.1"+    <*> m .:? "backend_port" .!= 8080+    <*> m .:? "backend_socket"+  parseJSON _ = empty++deriving instance Read LogLevel++parseLogLevel :: String -> Parser LogLevel+parseLogLevel s = (maybe err return . readMaybe . map toUpper) s+  where+    err = fail ("invalid log_level " ++ show s)++parseLogTarget :: String -> Parser LogTarget+parseLogTarget s = case s of+  "stderr" -> return StdErr+  "syslog" -> return SysLog+  _ -> fail ("invalid log_target " ++ show s)+

@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module Cookies (+  Name+, Value+, parseCookies+, removeCookie+, formatCookies+, setCookie+, invalidateCookie+) where++import           Data.String+import           Control.Applicative+import qualified Data.ByteString as BS+import Data.Char hiding (isSpace)+import Data.List (partition, intercalate)+import Network.HTTP.Types.Header (Header, hCookie)+import System.Posix.Types (EpochTime)+import Data.Attoparsec.ByteString.Char8++type Name = String+type Value = String++removeCookie :: String -> [(Name, Value)] -> Maybe (Value, [(Name, Value)])+removeCookie name cookies = case partition ((== name) . fst) cookies of+  ((_, x):_, xs) -> Just (x, xs)+  _ -> Nothing++setCookie :: String -> String -> String -> EpochTime -> String+setCookie domain name value maxAge = mkCookie domain [+    (name, value)+  , ("Max-Age", show maxAge)+  ]++invalidateCookie :: String -> String -> String+invalidateCookie domain name = mkCookie domain [+    (name, "deleted")+  , ("expires", "Thu, 01 Jan 1970 00:00:00 GMT")+  ]++mkCookie :: String -> [(String, String)] -> String+mkCookie domain = intercalate "; " . map format . (++ defaults) . map (fmap Just)+  where+    defaults = [+        ("Domain", Just domain)+      , ("path", Just "/")+      , ("HttpOnly", Nothing)+      , ("Secure", Nothing)+      ]+    format (name, mValue) = maybe name (\value -> name ++ "=" ++ value) mValue+++formatCookies :: [(Name, Value)] -> BS.ByteString+formatCookies = mconcat . intercalate ["; "] . map formatCookie+  where+    formatCookie (name, value) = [fromString name, "=", fromString value]++parseCookies :: [Header] -> [(Name, Value)]+parseCookies = foldr headerToCookies []++headerToCookies :: Header -> [(Name, Value)] -> [(Name, Value)]+headerToCookies (name, val) acc+  | name == hCookie = case parseOnly cookies val of+      Left{}  -> acc+      Right x -> x ++ acc+  | otherwise = acc+  where+   cookies :: Parser [(Name, Value)]+   cookies = sepBy1 cookie (";" *> skipSpace)++   cookie :: Parser (Name, Value)+   cookie = (,) <$> word <*> (skipSpace *> "=" *> skipSpace *> value)++   value :: Parser String+   value = quotedstring <|> many1 (satisfy (/= ';')) <|> return ""++quotedstring :: Parser String+quotedstring = char '"' *> many (satisfy  (/= '"')) <* char '"'++word :: Parser String+word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':'))+

@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}+module HTTP (+  hostHeaderMissing+, authenticationFailed+, accessDenied+, badRequest+, mkResponse+, mkTextResponse+, mkHtmlResponse+) where++import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import           Network.HTTP.Types+import           Network.HTTP.Toolkit+import           Network.HTTP.Toolkit.Body+import           Text.InterpolatedString.Perl6 (qc)++import qualified System.Logging.Facade as Log++hostHeaderMissing :: Request a -> IO (Response BodyReader)+hostHeaderMissing r = do+  Log.warn $ "Host header missing for request: " ++ show (requestMethod r, requestPath r, requestHeaders r)+  mkTextResponse badRequest400 "400 Bad Request"++authenticationFailed :: String -> IO (Response BodyReader)+authenticationFailed err = do+  Log.error err+  mkHtmlResponse internalServerError500 [qc|+<!DOCTYPE html>+<html lang="en">+  <head>+    <meta charset="utf-8">+    <title>Authentication Failed</title>+  </head>+  <body>+  <h1>Authentication Failed</h1>+    <p>Authentication Failed for an unknown reason.</p>+    <p><a href="/">Try again!</a></p>+  </body>+</html>+|]++accessDenied :: String -> IO (Response BodyReader)+accessDenied email = mkHtmlResponse forbidden403 [qc|+<!DOCTYPE html>+<html lang="en">+  <head>+    <meta charset="utf-8">+    <title>Access Denied</title>+  </head>+  <body>+  <h1>Access Denied</h1>+    <p>You are currently logged in as <strong>{email}</strong>.</p>+    <p><a href="/sproxy/logout">logout</a></p>+  </body>+</html>+|]++badRequest :: IO (Response BodyReader)+badRequest = mkTextResponse badRequest400 "400 Bad Request"++mkResponse :: Status -> [Header] -> ByteString -> IO (Response BodyReader)+mkResponse status headers_ body = Response status headers <$> fromByteString body+  where+    headers = ("Content-Length", B.pack . show . B.length $ body) : headers_++mkTextResponse :: Status -> ByteString -> IO (Response BodyReader)+mkTextResponse status = mkResponse status [("Content-Type", "text/plain")]++mkHtmlResponse :: Status -> ByteString -> IO (Response BodyReader)+mkHtmlResponse status = mkResponse status [("Content-Type", "text/html")]

@@ -0,0 +1,6 @@+module Logging (setup) where++import           System.Logging.LogSink.Config++setup :: LogLevel -> LogTarget -> IO ()+setup level target = setupLogging [SinkConfig level "{level} {thread-id}: {message}" target]

@@ -0,0 +1,43 @@+{-# LANGUAGE QuasiQuotes #-}+module Main+(+  main+) where++import Data.Maybe (fromJust)+import Data.Version (showVersion)+import Paths_sproxy (version) -- from cabal+import System.Environment (getArgs)+import Text.RawString.QQ (r)+import qualified System.Console.Docopt.NoTH as O++import Authorize (withDatabaseAuthorizeAction)+import ConfigFile (withConfigFile, ConfigFile(..))+import Proxy (run)++usage :: String+usage =  "SProxy " ++ showVersion version +++  " HTTP proxy for authenticating users via Google OAuth2" ++ [r|++Usage:+  sproxy [options]++Options:+  -c, --config=FILE        Configuration file [default: config/sproxy.yml]+  -h, --help               Show this message++|]++main :: IO ()+main = do+  doco <- O.parseUsageOrExit usage+  args <- O.parseArgsOrExit doco =<< getArgs+  if args `O.isPresent` O.longOption "help"+  then putStrLn $ O.usage doco+  else do+    let+      configFile = fromJust . O.getArg args $ O.longOption "config"++    withConfigFile configFile $ \config ->+      withDatabaseAuthorizeAction (cfDatabase config) (run config)+

@@ -0,0 +1,249 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+module Proxy (+  run+) where++import Control.Monad hiding (forM_)+import Data.Foldable (forM_)+import Control.Concurrent+import Control.Exception+import System.IO.Error+import GHC.IO.Exception+import Data.Monoid+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as BL+import Data.Default (def)+import Data.List (intercalate)+import Data.Maybe+import Data.Map as Map (fromListWith, toList, insert, delete)+import Data.String.Conversions (cs)+import qualified Data.X509 as X509+import Network (PortID(..), listenOn, sClose, connectTo)+import Network.Socket (Socket, SockAddr, accept, close)+import qualified Network.Socket.ByteString as Socket+import Network.HTTP.Types+import qualified Network.TLS as TLS+import qualified Network.TLS.Extra as TLS+import System.IO+import System.Entropy (getEntropy)+import qualified Data.ByteString.Base64 as Base64+import Network.HTTP.Toolkit++import qualified System.Logging.Facade as Log++import Type+import Util+import Logging+import Authenticate+import Cookies+import Authorize+import ConfigFile+import HTTP++data Config = Config {+  configTLSCredential :: TLS.Credential+, configBackendAddress :: String+, configBackendPortID :: PortID+} deriving (Eq, Show)++-- | Reads the configuration file and the ssl certificate files and starts+-- the server+run :: ConfigFile -> AuthorizeAction -> IO ()+run cf authorize = do+  Logging.setup (cfLogLevel cf) (cfLogTarget cf)+  clientSecret <- strip <$> readFile (cfClientSecretFile cf)+  authTokenKey <- B8.unpack . Base64.encode <$> getEntropy 32+  credential <- either error reverseCerts <$> TLS.credentialLoadX509 (cfSslCerts cf) (cfSslKey cf)++  let authConfig = AuthConfig {+          authConfigCookieDomain = cfCookieDomain cf+        , authConfigCookieName = cfCookieName cf+        , authConfigClientID = cfClientID cf+        , authConfigClientSecret = clientSecret+        , authConfigAuthTokenKey = authTokenKey+        }+      config = Config {+          configTLSCredential = credential+        , configBackendAddress = cfBackendAddress cf+        , configBackendPortID =+            case cfBackendSocket cf of+              Just path -> UnixSocket path+              _ -> PortNumber . fromIntegral $ cfBackendPort cf+        }++  case configBackendPortID config of+    UnixSocket path -> hPutStrLn stderr $ "Forwarding to UNIX socket " ++ path+    PortNumber p -> hPutStrLn stderr $ "Forwarding to "+                       ++ configBackendAddress config ++ ":"+                       ++ show p+    _ -> return () -- XXX can't happen++  mvar <- newEmptyMVar++  -- Immediately fork a new thread for accepting connections since+  -- the main thread is special and expensive to communicate with.+  void . forkIO $ (runProxy (PortNumber . fromIntegral $ cfListen cf)+                            config authConfig authorize `catch` logException)+                 `finally` putMVar mvar ()++  -- Listen on port 80 just to redirect everything to HTTPS.+  let listen80 = fromMaybe (443 == cfListen cf) (cfRedirectHttpToHttps cf)++  when listen80 $+    void . forkIO $ listen (PortNumber 80) redirectToHttps `catch` logException++  takeMVar mvar+  where+    -- Usually combined certs are in server, intermediate order,+    -- but the tls library expects them in the opposite order.+    reverseCerts (X509.CertificateChain certs, key) = (X509.CertificateChain $ reverse certs, key)++runProxy :: PortID -> Config -> AuthConfig -> AuthorizeAction -> IO ()+runProxy port config authConfig authorize = listen port (serve config authConfig authorize)++-- | Redirects requests to https.+redirectToHttps :: SockAddr -> Socket -> IO ()+redirectToHttps _ sock = do+  conn <- makeInputStream (Socket.recv sock 4096)+  request <- readRequest True conn++  case baseUri (requestHeaders request) of+    Just uri -> do+      let location = uri <> requestPath request+      Log.debug ("Redirecting HTTP request to " ++ show location)+      simpleResponse send seeOther303 [("Location", location)] ""+    Nothing -> hostHeaderMissing request >>= sendResponse send+  where+    send = Socket.sendAll sock++-- | Actual server:+-- - ssl handshake+-- - google authentication+-- - our authorization+-- - redirecting requests to localhost:8080+serve :: Config -> AuthConfig -> AuthorizeAction -> SockAddr -> Socket -> IO ()+serve config authConfig authorize addr sock = do+  -- TODO: Work in the intermediate certificates.+  let params = def { TLS.serverShared = def { TLS.sharedCredentials = TLS.Credentials [configTLSCredential config] }+                   , TLS.serverSupported = def { TLS.supportedVersions = [TLS.TLS10, TLS.TLS11, TLS.TLS12]+                                               , TLS.supportedCiphers = TLS.ciphersuite_all } }+  ctx <- TLS.contextNew sock params+  TLS.handshake ctx+  conn <- makeInputStream (TLS.recvData ctx)+  serve_ (TLS.sendData ctx . BL.fromStrict) conn+  TLS.bye ctx+  where+    serve_ :: SendData -> InputStream -> IO ()+    serve_ send conn = go+      where+        go :: IO ()+        go = do+          continue <- handleOne+          when continue go++        handleOne :: IO Bool+        handleOne = do+          request@(Request _ path headers _) <- readRequest True conn+          mResponse <- case baseUri (requestHeaders request) of+            Nothing -> Just <$> hostHeaderMissing request+            Just uri -> do+              let (segments, query) = (decodePath . extractPath) path+              let redirectPath = fromMaybe "/" $ join $ lookup "state" query+              case segments of+                ["sproxy", "oauth2callback"] ->+                  case join $ lookup "code" query of+                    Nothing -> Just <$> badRequest+                    Just code -> Just <$> authenticate authConfig uri redirectPath code+                ["sproxy", "logout"] ->+                  Just <$> logout authConfig (uri <> redirectPath)+                -- sproxy sites are private by design. It doesn't make sense to index the authentication page.+                ["robots.txt"] -> Just <$> mkTextResponse ok200 "User-agent: *\nDisallow: /"+                _ -> -- Check for an auth cookie.+                  case removeCookie (authConfigCookieName authConfig) (parseCookies headers) of+                    Nothing -> Just <$> redirectForAuth authConfig path uri+                    Just (authCookie, cookies) -> do+                      auth <- validAuth authConfig authCookie+                      case auth of+                        Nothing -> Just <$> redirectForAuth authConfig path uri+                        Just token ->+                          forwardRequest config send authorize cookies addr request token+          forM_ mResponse (sendResponse send)+          return ((not . isConnectionClose) headers)++-- Check our access control list for this user's request and forward it to the backend if allowed.+forwardRequest :: Config -> SendData -> AuthorizeAction -> [(Name, Cookies.Value)] -> SockAddr -> Request BodyReader -> AuthToken -> IO (Maybe (Response BodyReader))+forwardRequest config send authorize cookies addr request@(Request method path headers _) token = do+    groups <- authorize (authEmail token) (maybe (error "No Host") cs $ lookup "Host" headers) path method+    ip <- formatSockAddr addr+    case groups of+        [] -> Just <$> accessDenied (authEmail token)+        _ -> do+            -- TODO: Reuse connections to the backend server.+            let downStreamHeaders =+                    toList $+                    insert "From" (cs $ authEmail token) $+                    insert "X-Groups" (cs $ intercalate "," groups) $+                    insert "X-Given-Name" (cs $ fst $ authName token) $+                    insert "X-Family-Name" (cs $ snd $ authName token) $+                    insert "X-Forwarded-Proto" "https" $+                    addForwardedForHeader ip $+                    insert "Connection" "close" $+                    setCookies $ fromListWith (\a b -> B8.concat [a, ",", b]) headers+            Log.debug $ show downStreamHeaders+            bracket (connectTo host portID) hClose $ \h -> do+              sendRequest (B8.hPutStr h) request{requestHeaders = downStreamHeaders}+              conn <- inputStreamFromHandle h+              response <- readResponse True method conn+              sendResponse send response{responseHeaders = removeConnectionHeader (responseHeaders response)}+              return Nothing+  where+    host = configBackendAddress config+    portID = configBackendPortID config+    setCookies = case cookies of+      [] -> delete hCookie+      _  -> insert hCookie (formatCookies cookies)++listen :: PortID -> (SockAddr -> Socket -> IO ()) -> IO ()+listen port action =+  bracket+  ( do+    sock <- listenOn port+    hPutStrLn stderr $ "Listening on " ++ show port+    return sock )+  sClose $+  \serverSock -> forever $ do+  (sock, addr) <- accept serverSock+  forkIO $ (action addr sock `finally` close sock) `catches` handlers+  where+    handlers = [ Handler ioH+               , Handler toolkitH+               , Handler tlsH+               , Handler logException ]++    ioH :: IOException -> IO ()+    ioH e+      | ResourceVanished == ioeGetErrorType e = clientClosedConection e+      | otherwise = logException' e++    toolkitH :: ToolkitError -> IO ()+    toolkitH e@UnexpectedEndOfInput = clientClosedConection e+    toolkitH e = logException' e++    tlsH :: TLS.TLSException -> IO ()+    tlsH e@(TLS.HandshakeFailed TLS.Error_EOF) = clientClosedConection e+    tlsH e@(TLS.HandshakeFailed (TLS.Error_Protocol (_, _, _))) = clientError e+    tlsH e@(TLS.HandshakeFailed (TLS.Error_Packet_Parsing _)) = clientError e+    tlsH e = logException' e++    logException' :: Exception e => e -> IO ()+    logException' = logException . toException++    clientClosedConection :: Exception e => e -> IO ()+    clientClosedConection e = Log.debug ("client closed connection (" ++ displayException e ++ ")")++    clientError :: Exception e => e -> IO ()+    clientError e = Log.debug ("client error (" ++ displayException e ++ ")")++logException :: SomeException -> IO ()+logException = Log.error . displayException+

@@ -0,0 +1,5 @@+module Type where++import           Data.ByteString (ByteString)++type SendData = ByteString -> IO ()

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}+module Util where++import           Data.Char+import           Data.String+import           Data.Monoid+import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import           Network.HTTP.Types+import           Network.Socket++formatSockAddr :: SockAddr -> IO HostName+formatSockAddr addr = (fst <$> getNameInfo [NI_NUMERICHOST] True False addr) >>= maybe err return+  where+    err = error "Util.formatSockAddr: impossible internal error"++addForwardedForHeader :: HostName -> Map HeaderName ByteString -> Map HeaderName ByteString+addForwardedForHeader ip = Map.insertWith combine "X-Forwarded-For" (fromString ip)+  where+    combine new old = mconcat [old, ", ", new]++removeConnectionHeader :: [Header] -> [Header]+removeConnectionHeader = filter ((/= hConnection) . fst)++strip :: String -> String+strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace++baseUri :: [Header] -> Maybe ByteString+baseUri headers = ("https://" <>) <$> lookup "Host" headers++isConnectionClose :: [Header] -> Bool+isConnectionClose = any p+  where+    p (k, v) = k == hConnection && B.map toLower (stripBS v) == "close"+    stripBS = B.reverse . B.dropWhile isSpace . B.reverse . B.dropWhile isSpace