aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--.gitignore7
-rw-r--r--ChangeLog.md43
-rw-r--r--LICENSE20
-rw-r--r--README.md161
-rw-r--r--Setup.hs2
-rw-r--r--sproxy.sql168
-rw-r--r--sproxy.yml.example139
-rw-r--r--sproxy2.cabal72
-rw-r--r--src/Main.hs37
-rw-r--r--src/Sproxy/Application.hs372
-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
-rw-r--r--src/Sproxy/Config.hs88
-rw-r--r--src/Sproxy/Logging.hs99
-rw-r--r--src/Sproxy/Server.hs190
-rw-r--r--src/Sproxy/Server/DB.hs189
20 files changed, 1879 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..0c5653f
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,7 @@
+*.sqlite3*
+*.swp
+/.cabal-sandbox/
+/cabal-dev/
+/cabal.sandbox.config
+/dist/
+sproxy.yml
diff --git a/ChangeLog.md b/ChangeLog.md
new file mode 100644
index 0000000..208a845
--- /dev/null
+++ b/ChangeLog.md
@@ -0,0 +1,43 @@
+For differences with the original Sproxy scroll down.
+
+1.90.0 (Preview Release)
+========================
+
+Sproxy2 is overhaul of original [Sproxy](https://github.com/zalora/sproxy)
+(see also [Hackage](https://hackage.haskell.org/package/sproxy)).
+Here are the key differences (with Sproxy 0.9.8):
+
+ * Sproxy2 can work with remote PostgreSQL database. Quick access to the database is essential
+ as sproxy does it on every HTTP request. Sproxy2 pulls data into local SQLite3 database.
+
+ * At this release Sproxy2 is compatible with Sproxy database with one exception:
+ SQL wildcards are not supported for HTTP methods. E. i. you have to change '%' in
+ the database to specific methods like GET, POST, etc.
+
+ * OAuth2 callback URLs changed: Sproxy2 uses `/.sproxy/oauth2/:provider`,
+ e. g. `/.sproxy/oauth2/google`. Sproxy used `/sproxy/oauth2callback` for Google
+ and `/sproxy/oauth2callback/linkedin` for LinkedIn.
+
+ * Sproxy2 does not allow login with email addresses not known to it.
+
+ * Sproxy2: OAuth2 callback state is serialized, signed and passed base64-encoded.
+ Of course it's used to verify the request is legit.
+
+ * Sproxy2: session cookie is serialized, signed and sent base64-encoded.
+
+ * Path `/.sproxy` belongs to Sproxy2 completely. Anything under this path is never passed to backends.
+
+ * Sproxy2 supports multiple backends. Routing is based on the Host HTTP header.
+
+ * Sproxy2 uses [WAI](https://hackage.haskell.org/package/wai) / [Warp](https://hackage.haskell.org/package/warp)
+ for incoming connections. As a result Sproxy2 supports HTTP2.
+
+ * Sproxy2 uses [HTTP Client](https://hackage.haskell.org/package/http-client) to talk to backends.
+ As a result Sproxy2 reuses backend connections instead of closing them after each request to the backend.
+
+ * Sproxy2 optionally supports persistent key again (removed in Sproxy 0.9.2).
+ This can be used in load-balancing multiple Sproxy2 instances.
+
+ * Configuration file has changed. It's still YAML, but some options are renamed, removed or added.
+ Have a look at well-documented [sproxy.yml.example](./sproxy.yml.example)
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..f754880
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,20 @@
+Copyright (c) 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.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..aa2f998
--- /dev/null
+++ b/README.md
@@ -0,0 +1,161 @@
+# Sproxy2 - HTTP proxy for authenticating users via OAuth2
+
+## Motivation
+
+This is overhaul of original [Sproxy](https://hackage.haskell.org/package/sproxy).
+See [ChangeLog.md](./ChangeLog.md) for the differences.
+
+Why use a proxy for doing OAuth2? 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.
+
+## Use cases
+
+ * Existing web applications with concept of roles. For example,
+ [Mediawiki](https://www.mediawiki.org), [Jenkins](https://jenkins.io),
+ [Icinga Web 2](https://www.icinga.org/products/icinga-web-2/). In
+ this case you configure Sproxy to allow unrestricted access
+ to the application for some groups defined by Sproxy. These
+ groups are mapped to the application roles. There is a [plugin for
+ Jenkins](https://wiki.jenkins-ci.org/display/JENKINS/Reverse+Proxy+Auth+Plugin)
+ which can be used for this. Mediawiki and Icinga Web 2 were also
+ successfully deployed in this way, though it required changes to their
+ source code.
+
+ * New web applications designed to work specifically behind Sproxy. In this case
+ you define Sproxy rules to control access to the
+ application's API. It would likely be [a single-page
+ application](https://en.wikipedia.org/wiki/Single-page_application).
+ Examples are [MyWatch](https://hackage.haskell.org/package/mywatch) and
+ [Juan de la Cosa](https://hackage.haskell.org/package/juandelacosa)
+
+## 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, expired), it responses with [HTTP
+status 511](https://tools.ietf.org/html/rfc6585) with the page, where the
+user can choose an [OAuth2](https://tools.ietf.org/html/rfc6749) provider to
+authenticate with. 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.
+
+
+## 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 login
+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:
+
+
+Do note that Sproxy2 fetches only `group_member`, `group_privilege` and `privilege_rule`
+tables, because only these tables are used for authorization. The other tables
+serve for data integrity.
+
+
+### Privileges example
+
+Consider this `group_privilege` and `privilege_rule` relations:
+
+group | privilege | domain
+---------------- | --------- | -----------------
+`readers` | `basic` | `wiki.example.com`
+`readers` | `read` | `wiki.example.com`
+`editors` | `basic` | `wiki.example.com`
+`editors` | `read` | `wiki.example.com`
+`editors` | `edit` | `wiki.example.com`
+`administrators` | `basic` | `wiki.example.com`
+`administrators` | `read` | `wiki.example.com`
+`administrators` | `edit` | `wiki.example.com`
+`administrators` | `admin` | `wiki.example.com`
+
+privilege | domain | path | method
+----------- | ------------------ | -------------- | ------
+`basic` | `wiki.example.com` | `/%` | `GET`
+`read` | `wiki.example.com` | `/wiki/%` | `GET`
+`edit` | `wiki.example.com` | `/wiki/edit/%` | `GET`
+`edit` | `wiki.example.com` | `/wiki/edit/%` | `POST`
+`admin` | `wiki.example.com` | `/admin/%` | `GET`
+`admin` | `wiki.example.com` | `/admin/%` | `POST`
+`admin` | `wiki.example.com` | `/admin/%` | `DELETE`
+
+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 `sproxy2` will read its configuration from
+`sproxy.yml`. There is example file with documentation
+[sproxy.yml.example](sproxy.yml.example). You can specify a
+custom path with:
+
+```
+sproxy --config /path/to/sproxy.yml
+```
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/sproxy.sql b/sproxy.sql
new file mode 100644
index 0000000..cda98f4
--- /dev/null
+++ b/sproxy.sql
@@ -0,0 +1,168 @@
+/*
+
+-- as super user:
+
+-- NOT idempotent
+CREATE DATABASE sproxy;
+CREATE ROLE sproxy; -- this is for management tools like sproxy-web
+CREATE ROLE "sproxy-readonly"; -- this is for sproxy itself (sic!)
+
+-- idempotent from here on:
+ALTER DATABASE sproxy OWNER TO sproxy;
+ALTER ROLE "sproxy-readonly" LOGIN;
+ALTER ROLE sproxy LOGIN;
+
+\c sproxy;
+
+SET ROLE sproxy;
+-- as database owner (sproxy) from here on:
+
+GRANT SELECT ON ALL TABLES IN SCHEMA public TO "sproxy-readonly";
+ALTER DEFAULT PRIVILEGES IN SCHEMA public GRANT SELECT ON TABLES TO "sproxy-readonly";
+
+*/
+
+
+BEGIN;
+
+CREATE TABLE IF NOT EXISTS "group" (
+ "group" TEXT NOT NULL PRIMARY KEY,
+ "comment" TEXT
+);
+
+-- | group |
+-- |--------------|
+-- | data science |
+-- | devops |
+-- | all |
+-- | regional |
+
+
+CREATE TABLE IF NOT EXISTS group_member (
+ "group" TEXT REFERENCES "group" ("group") ON UPDATE CASCADE ON DELETE CASCADE NOT NULL,
+ email TEXT NOT NULL,
+ "comment" TEXT,
+ PRIMARY KEY ("group", email)
+);
+
+-- | group | email |
+-- |--------------+------------------------|
+-- | data science | blah@example.com |
+-- | data science | foo@example.com |
+-- | devops | devops1@example.com |
+-- | devops | devops2@example.com |
+-- | all | %@example.com |
+
+-- 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,
+ "comment" TEXT
+);
+
+-- | domain |
+-- |-----------------------|
+-- | app1.example.com |
+-- | app2.example.com |
+-- | app3.example.com |
+
+CREATE TABLE IF NOT EXISTS privilege (
+ "domain" TEXT REFERENCES domain (domain) ON UPDATE CASCADE ON DELETE CASCADE NOT NULL,
+ privilege TEXT NOT NULL,
+ "comment" TEXT,
+ PRIMARY KEY ("domain", privilege)
+);
+
+-- | domain | privilege |
+-- |-----------------------+------------|
+-- | app3.example.com | view |
+-- | app3.example.com | export |
+-- | app1.example.com | list users |
+-- | app1.example.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,
+ "comment" TEXT,
+ FOREIGN KEY ("domain", privilege) REFERENCES privilege ("domain", privilege) ON UPDATE CASCADE ON DELETE CASCADE,
+ PRIMARY KEY ("domain", "path", "method")
+);
+
+-- | domain | privilege | path | method |
+-- |-----------------------+------------+-----------+--------|
+-- | app3.example.com | view | /% | % |
+-- | app3.example.com | export | /export/% | % |
+-- | app1.example.com | list users | /users | GET |
+-- | app1.example.com | list users | /user/% | GET |
+-- | app1.example.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,
+ "comment" TEXT,
+ 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.example.com | view |
+-- | data science | app3.example.com | export |
+-- | all | app1.example.com | list users |
+-- | devops | app1.example.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.example.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@example.com' LIKE email
+-- AND 'app3.example.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.example.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.example.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 ('example.com');
+ INSERT INTO "group" ("group") VALUES ('dev');
+ INSERT INTO group_member ("group", email) VALUES ('dev', '%');
+ INSERT INTO privilege (domain, privilege) VALUES ('example.com', 'full');
+ INSERT INTO group_privilege ("group", domain, privilege) VALUES ('dev', 'example.com', 'full');
+ INSERT INTO privilege_rule (domain, privilege, path, method) VALUES ('example.com', 'full', '%', '%');
+*/
+
+END;
+
diff --git a/sproxy.yml.example b/sproxy.yml.example
new file mode 100644
index 0000000..d539956
--- /dev/null
+++ b/sproxy.yml.example
@@ -0,0 +1,139 @@
+--- # Sproxy configuration. Don't remove this line. This is YAML: https://en.wikipedia.org/wiki/YAML
+
+# The port Sproxy listens on (HTTPS).
+# Optional. Default is 443.
+#
+# listen: 443
+
+# Listen on port 80 and redirect HTTP requests to HTTPS.
+# Optional. Default is true when listen == 443, otherwise false.
+#
+# listen80: true
+
+# Whether HTTP2 is enabled. Optional. Default is "true"
+#
+# http2: true
+
+# The system user Sproxy switches to if launched as root (after opening the ports).
+# Optional. Default is sproxy.
+#
+# user: sproxy
+
+# Home directory for various files including SQLite3 authorization database.
+# Optional. Default is current directory.
+#
+# home: "."
+
+# PostgreSQL database connection string.
+# Optional. If specified, sproxy will periodically pull the data from this
+# database into internal SQLite3 database. Define password in a file
+# referenced by the PGPASSFILE environment variable. Or use the "pgpassfile" option.
+# Example:
+# database: "user=sproxy-readonly dbname=sproxy port=6001"
+#
+# database:
+
+# PostgreSQL password file.
+# Optional. If specified, sproxy will set PGPASSFILE environment variable pointing to this file
+# Example:
+# pgpassfile: /run/keys/sproxy.pgpass
+#
+# pgpassfile:
+
+# Logging level: debug, info, warn, error.
+# Optional. Default is debug.
+#
+# log_level: debug
+
+# A file with arbitrary content used to sign sproxy cookie and other things (secret!).
+# Optional. If not specified, a random key is generated on startup, and
+# as a consequence, restaring sproxy will invalidate existing user sessions.
+# This option could be useful for load-balancing with multiple sproxy instances,
+# when all instances must understand cookies created by each other.
+# This should not be very large, a few random bytes are fine.
+#
+# key: /run/keys/sproxy.secret
+
+# File with SSL certificate. Required.
+# It can be a bundle with the server certificate coming first:
+# cat me-cert.pem CA-cert.pem > cert.pem
+# Once again: most wanted certs go first ;-)
+# Or you can opt in using of `ssl_cert_chain`
+ssl_cert: /path/cert.pem
+
+# File with SSL key (secret!). Required.
+ssl_key: /path/key.pem
+
+# Chain SSL certificate files.
+# Optional. Default is an empty list
+# Example:
+# ssl_cert_chain:
+# - /path/foo.pem
+# - /path/bar.pem
+#
+# ssl_cert_chain: []
+
+
+# Credentials for supported OAuth2 providers.
+# Currently supported: "google", "linkedin"
+# At least one provider is required.
+# Attributes:
+# client_id - OAuth2 client ID (string)
+# client_secret - OAuth2 client secret. Regardless of its name, this is a file.
+# The secret is read from the file which you should keep secret.
+# Only the first line of this file is read.
+#
+# Example:
+# oauth2:
+# google:
+# client_id: "XXXXXXXXXXXX-YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY.apps.googleusercontent.com"
+# client_secret: "/run/keys/XXXXXXXXXXXX-YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY.apps.googleusercontent.com"
+#
+# linkedin:
+# client_id: "xxxxxxxxxxxxxx"
+# client_secret: "/run/keys/xxxxxxxxxxxxxx"
+#
+#
+# oauth2:
+# google:
+# client_id:
+# client_secret:
+
+
+# Backend servers. At least one is required.
+# NOTE: backends at TCP port are not secure, even on localhost,
+# because any local user can connect to the backend bypassing sproxy
+# authentication and authorization.
+#
+# It is recommended to communicate with backends via unix sockets only.
+# Unix sockets should be secured with proper unix file permissions.
+#
+# Backend attributes:
+# name - the host name as in the Host HTTP header.
+# May include wildcards * and ?. The first matching
+# backend will be used. Examples: "*.example.com", "wiki.corp.com".
+# Optional. Default is "*". Note, that the name must include
+# port number if non-standard.
+# address - backend IP address. Optional. Default is 127.0.0.1.
+# port - backend TCP port. Required unless unix socket is defined.
+# socket - unix socket. Highly recommended for security reasons.
+# If defined, IP address and TCP port are ignored.
+#
+# cookie_name - sproxy cookie name. Optional. Default is "sproxy".
+# cookie_domain - sproxy cookie domain. Optional. Default is the request host name as per RFC2109.
+# cookie_max_age - sproxy cookie shelflife in seconds. Optional. Default is 604800 (7 days).
+# conn_count - number of connections to keep alive. Optional. Default is 32.
+# This is specific to Haskell HTTP Client library, and is per host name,
+# not per backend. HTTP Client's default is 10.
+#
+# backends:
+# - name: wiki.example.com
+# port: 9090
+# cookie_name: sproxy_example
+# cookie_max_age: 86400
+#
+backends:
+ - port: 8080
+
+... # End of configuration. Don't remove this line. This is YAML: https://en.wikipedia.org/wiki/YAML
+
diff --git a/sproxy2.cabal b/sproxy2.cabal
new file mode 100644
index 0000000..f0817c0
--- /dev/null
+++ b/sproxy2.cabal
@@ -0,0 +1,72 @@
+name: sproxy2
+version: 1.90.0
+synopsis: Secure HTTP proxy for authenticating users via OAuth2
+description:
+ Sproxy is secure by default. No requests makes it to the backend
+ server if they haven't been explicitly whitelisted. Sproxy is
+ independent. Any web application written in any language can
+ use it.
+license: MIT
+license-file: LICENSE
+author: Igor Pashev <pashev.igor@gmail.com>
+maintainer: Igor Pashev <pashev.igor@gmail.com>
+copyright: 2016, Zalora South East Asia Pte. Ltd
+category: Databases, Web
+build-type: Simple
+extra-source-files: README.md ChangeLog.md sproxy.yml.example sproxy.sql
+cabal-version: >= 1.20
+
+source-repository head
+ type: git
+ location: https://github.com/ip1981/sproxy2.git
+
+executable sproxy2
+ default-language: Haskell2010
+ ghc-options: -Wall -static -threaded
+ hs-source-dirs: src
+ main-is: Main.hs
+ other-modules:
+ Sproxy.Application
+ Sproxy.Application.Cookie
+ Sproxy.Application.OAuth2
+ Sproxy.Application.OAuth2.Common
+ Sproxy.Application.OAuth2.Google
+ Sproxy.Application.OAuth2.LinkedIn
+ Sproxy.Application.State
+ Sproxy.Config
+ Sproxy.Logging
+ Sproxy.Server
+ Sproxy.Server.DB
+ build-depends:
+ base >= 4.8 && < 50
+ , aeson
+ , base64-bytestring
+ , blaze-builder
+ , bytestring
+ , cereal
+ , conduit
+ , containers
+ , cookie >= 0.4.2
+ , docopt
+ , entropy
+ , Glob
+ , http-client >= 0.5.3
+ , http-conduit
+ , http-types
+ , interpolatedstring-perl6
+ , network
+ , postgresql-simple
+ , resource-pool
+ , SHA
+ , sqlite-simple
+ , text
+ , time
+ , unix
+ , unordered-containers
+ , wai
+ , wai-conduit
+ , warp
+ , warp-tls >= 3.2
+ , word8
+ , yaml >= 0.8.4
+
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..7101af0
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE QuasiQuotes #-}
+module Main (
+ main
+) where
+
+import Data.Maybe (fromJust)
+import Data.Version (showVersion)
+import Paths_sproxy2 (version) -- from cabal
+import System.Environment (getArgs)
+import Text.InterpolatedString.Perl6 (qc)
+import qualified System.Console.Docopt.NoTH as O
+
+import Sproxy.Server (server)
+
+usage :: String
+usage = "sproxy2 " ++ showVersion version ++
+ " - HTTP proxy for authenticating users via OAuth2" ++ [qc|
+
+Usage:
+ sproxy2 [options]
+
+Options:
+ -c, --config=FILE Configuration file [default: 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"
+ server configFile
+
diff --git a/src/Sproxy/Application.hs b/src/Sproxy/Application.hs
new file mode 100644
index 0000000..2391220
--- /dev/null
+++ b/src/Sproxy/Application.hs
@@ -0,0 +1,372 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Sproxy.Application (
+ sproxy
+, redirect
+) where
+
+import Blaze.ByteString.Builder (toByteString)
+import Blaze.ByteString.Builder.ByteString (fromByteString)
+import Control.Exception (SomeException, catch)
+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)
+import Data.HashMap.Strict as HM (HashMap, foldrWithKey, lookup)
+import Data.List (find, partition)
+import Data.Map as Map (delete, fromListWith, insert, insertWith, toList)
+import Data.Maybe (fromJust, fromMaybe)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+import Data.Word (Word16)
+import Data.Word8 (_colon)
+import Foreign.C.Types (CTime(..))
+import Network.HTTP.Client.Conduit (bodyReaderSource)
+import Network.HTTP.Conduit (requestBodySourceChunkedIO, requestBodySourceIO)
+import Network.HTTP.Types (RequestHeaders, ResponseHeaders, hConnection,
+ hContentLength, hContentType, hCookie, hLocation, methodGet)
+import Network.HTTP.Types.Status ( Status(..), badRequest400, forbidden403, found302,
+ internalServerError500, methodNotAllowed405, movedPermanently301,
+ networkAuthenticationRequired511, notFound404, ok200, seeOther303, temporaryRedirect307 )
+import Network.Socket (NameInfoFlag(NI_NUMERICHOST), getNameInfo)
+import Network.Wai.Conduit (sourceRequestBody, responseSource)
+import System.FilePath.Glob (Pattern, match)
+import System.Posix.Time (epochTime)
+import Text.InterpolatedString.Perl6 (qc)
+import Web.Cookie (Cookies, parseCookies, renderCookies)
+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.OAuth2.Common (OAuth2Client(..))
+import Sproxy.Config(BackendConf(..))
+import Sproxy.Server.DB (Database, userExists, userGroups)
+import qualified Sproxy.Application.State as State
+import qualified Sproxy.Logging as Log
+
+
+redirect :: Word16 -> W.Application
+redirect p req resp =
+ case W.requestHeaderHost req of
+ Nothing -> badRequest "missing host" req resp
+ Just host -> do
+ Log.info $ "redirecting to " ++ show location ++ ": " ++ showReq req
+ resp $ W.responseBuilder status [(hLocation, location)] mempty
+ where
+ status = if W.requestMethod req == methodGet then movedPermanently301 else temporaryRedirect307
+ (domain, _) = BS.break (== _colon) host
+ newhost = if p == 443 then domain else domain <> ":" <> pack (show p)
+ location = "https://" <> newhost <> W.rawPathInfo req <> W.rawQueryString req
+
+
+sproxy :: ByteString -> Database -> HashMap Text OAuth2Client -> [(Pattern, BackendConf, BE.Manager)] -> W.Application
+sproxy key db oa2 backends = logException $ \req resp -> do
+ Log.debug $ "sproxy <<< " ++ showReq req
+ case W.requestHeaderHost req of
+ Nothing -> badRequest "missing host" req resp
+ Just host ->
+ case find (\(p, _, _) -> match p (unpack host)) backends of
+ Nothing -> notFound "backend" req resp
+ Just (_, be, mgr) -> do
+ let cookieName = pack $ beCookieName be
+ cookieDomain = pack <$> beCookieDomain be
+ case W.pathInfo req of
+ ["robots.txt"] -> get robots req resp
+ (".sproxy":proxy) ->
+ case proxy of
+ ["logout"] ->
+ case extractCookie key Nothing cookieName req of
+ Nothing -> notFound "logout without the cookie" req resp
+ Just _ -> get (logout cookieName cookieDomain) req resp
+ ["oauth2", provider] ->
+ case HM.lookup provider oa2 of
+ Nothing -> notFound "OAuth2 provider" req resp
+ Just oa2c -> get (oauth2callback key db (provider, oa2c) be) req resp
+ _ -> notFound "proxy" req resp
+ _ -> do
+ now <- Just <$> epochTime
+ case extractCookie key now cookieName req of
+ Nothing -> authenticationRequired key oa2 req resp
+ Just cs@(authCookie, _) ->
+ authorize db cs req >>= \case
+ Nothing -> forbidden authCookie req resp
+ Just req' -> forward mgr req' resp
+
+
+robots :: W.Application
+robots _ resp = resp $
+ W.responseLBS ok200 [(hContentType, "text/plain; charset=utf-8")]
+ "User-agent: *\nDisallow: /"
+
+
+oauth2callback :: ByteString -> Database -> (Text, OAuth2Client) -> BackendConf -> W.Application
+oauth2callback key db (provider, oa2c) be req resp =
+ case param "code" of
+ Nothing -> badRequest "missing auth code" req resp
+ Just code ->
+ case param "state" of
+ Nothing -> badRequest "missing auth state" req resp
+ Just state ->
+ case State.decode key state of
+ 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
+ exists <- userExists db email
+ if exists then authenticate key be au{auEmail = email} path req resp
+ else userNotFound email req resp
+ where
+ param p = do
+ (_, v) <- find ((==) p . fst) $ W.queryString req
+ v
+
+
+-- XXX: RFC6265: the user agent MUST NOT attach more than one Cookie header field
+extractCookie :: ByteString -> Maybe CTime -> ByteString -> W.Request -> Maybe (AuthCookie, Cookies)
+extractCookie key now name req = do
+ (_, cookies) <- find ((==) hCookie . fst) $ W.requestHeaders req
+ (auth, others) <- discriminate cookies
+ case cookieDecode key auth of
+ Left _ -> Nothing
+ Right cookie -> if maybe True (acExpiry cookie >) now
+ then Just (cookie, others) else Nothing
+ where discriminate cs =
+ case partition ((==) name . fst) $ parseCookies cs of
+ ((_, x):_, xs) -> Just (x, xs)
+ _ -> Nothing
+
+
+authenticate :: ByteString -> BackendConf -> AuthUser -> ByteString -> W.Application
+authenticate key be user path req resp = do
+ now <- epochTime
+ let host = fromJust $ W.requestHeaderHost req
+ domain = pack <$> beCookieDomain be
+ expiry = now + CTime (beCookieMaxAge be)
+ authCookie = AuthCookie { acUser = user, acExpiry = expiry }
+ cookie = WC.def {
+ WC.setCookieName = pack $ beCookieName be
+ , WC.setCookieHttpOnly = True
+ , WC.setCookiePath = Just "/"
+ , WC.setCookieSameSite = Nothing
+ , WC.setCookieSecure = True
+ , WC.setCookieValue = cookieEncode key authCookie
+ , WC.setCookieDomain = domain
+ , WC.setCookieExpires = Just . posixSecondsToUTCTime . realToFrac $ expiry
+ }
+ resp $ W.responseLBS seeOther303 [
+ (hLocation, "https://" <> host <> path)
+ , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie)
+ ] ""
+
+
+authorize :: Database -> (AuthCookie, Cookies) -> W.Request -> IO (Maybe W.Request)
+authorize db (authCookie, otherCookies) req = do
+ 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 "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)
+
+
+forward :: BE.Manager -> W.Application
+forward mgr req resp = do
+ let beReq = BE.defaultRequest
+ { BE.method = W.requestMethod req
+ , BE.path = W.rawPathInfo req
+ , BE.queryString = W.rawQueryString req
+ , BE.requestHeaders = modifyRequestHeaders $ W.requestHeaders req
+ , BE.redirectCount = 0
+ , BE.decompress = const False
+ , BE.requestBody = case W.requestBodyLength req of
+ W.ChunkedBody -> requestBodySourceChunkedIO (sourceRequestBody req)
+ W.KnownLength l -> requestBodySourceIO (fromIntegral l) (sourceRequestBody req)
+ }
+ msg = unpack (BE.method beReq <> " " <> BE.path beReq <> BE.queryString beReq)
+ Log.debug $ "BACKEND <<< " ++ msg ++ " " ++ show (BE.requestHeaders beReq)
+ BE.withResponse beReq mgr $ \res -> do
+ let status = BE.responseStatus res
+ headers = modifyResponseHeaders $ BE.responseHeaders res
+ body = mapOutput (Chunk . fromByteString) . bodyReaderSource $ BE.responseBody res
+ logging = if statusCode status `elem` [ 400, 500 ] then
+ Log.warn else Log.debug
+ logging $ "BACKEND >>> " ++ show (statusCode status) ++ " on " ++ msg ++ "\n"
+ resp $ responseSource status headers body
+
+
+modifyRequestHeaders :: RequestHeaders -> RequestHeaders
+modifyRequestHeaders = filter (\(n, _) -> n `notElem` ban)
+ where
+ ban =
+ [
+ hConnection
+ , hContentLength -- XXX to avoid duplicate header
+ ]
+
+modifyResponseHeaders :: ResponseHeaders -> ResponseHeaders
+modifyResponseHeaders = filter (\(n, _) -> n `notElem` ban)
+ where
+ ban =
+ [
+ hConnection
+ ]
+
+authenticationRequired :: ByteString -> HashMap Text OAuth2Client -> W.Application
+authenticationRequired key oa2 req resp = do
+ Log.info $ "511 Unauthenticated: " ++ showReq req
+ resp $ W.responseLBS networkAuthenticationRequired511 [(hContentType, "text/html; charset=utf-8")] page
+ where
+ path = W.rawPathInfo req -- FIXME: make it more robust for non-GET or XMLHTTPRequest?
+ state = State.encode key path
+ authLink :: Text -> OAuth2Client -> ByteString -> ByteString
+ authLink provider oa2c html =
+ let u = oauth2AuthorizeURL oa2c state (redirectURL req provider)
+ d = pack $ oauth2Description oa2c
+ in [qc|{html}<p><a href="{u}">Authenticate with {d}</a></p>|]
+ authHtml = foldrWithKey authLink "" oa2
+ page = fromStrict [qc|
+<!DOCTYPE html>
+<html lang="en">
+ <head>
+ <meta charset="utf-8">
+ <title>Authentication required</title>
+ </head>
+ <body style="text-align:center;">
+ <h1>Authentication required</h1>
+ {authHtml}
+ </body>
+</html>
+|]
+
+
+forbidden :: AuthCookie -> W.Application
+forbidden ac req resp = do
+ Log.info $ "403 Forbidden (" ++ email ++ "): " ++ showReq req
+ resp $ W.responseLBS forbidden403 [(hContentType, "text/html; charset=utf-8")] page
+ where
+ email = auEmail . acUser $ ac
+ page = fromStrict [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>
+|]
+
+
+userNotFound :: String -> W.Application
+userNotFound email _ resp = do
+ Log.info $ "404 User not found (" ++ email ++ ")"
+ resp $ W.responseLBS notFound404 [(hContentType, "text/html; charset=utf-8")] page
+ where
+ page = fromStrict [qc|
+<!DOCTYPE html>
+<html lang="en">
+ <head>
+ <meta charset="utf-8">
+ <title>Access Denied</title>
+ </head>
+ <body>
+ <h1>Access Denied</h1>
+ <p>You are not allowed to login as <strong>{email}</strong></p>
+ <p><a href="/">Main page</a></p>
+ </body>
+</html>
+|]
+
+
+logout :: ByteString -> Maybe ByteString -> W.Application
+logout name domain req resp = do
+ let host = fromJust $ W.requestHeaderHost req
+ cookie = WC.def {
+ WC.setCookieName = name
+ , WC.setCookieHttpOnly = True
+ , WC.setCookiePath = Just "/"
+ , WC.setCookieSameSite = Just WC.sameSiteStrict
+ , WC.setCookieSecure = True
+ , WC.setCookieValue = "goodbye"
+ , WC.setCookieDomain = domain
+ , WC.setCookieExpires = Just . posixSecondsToUTCTime . realToFrac $ CTime 0
+ }
+ resp $ W.responseLBS found302 [
+ (hLocation, "https://" <> host)
+ , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie)
+ ] ""
+
+
+badRequest ::String -> W.Application
+badRequest msg req resp = do
+ Log.warn $ "400 Bad Request (" ++ msg ++ "): " ++ showReq req
+ resp $ W.responseLBS badRequest400 [] "Bad Request"
+
+
+notFound ::String -> W.Application
+notFound msg req resp = do
+ Log.warn $ "404 Not Found (" ++ msg ++ "): " ++ showReq req
+ resp $ W.responseLBS notFound404 [] "Not Found"
+
+
+logException :: W.Middleware
+logException app req resp = catch (app req resp) $ \e -> do
+ Log.error $ "500 Internal Error: " ++ show (e :: SomeException) ++ " on " ++ showReq req
+ resp $ W.responseLBS internalServerError500 [] "Internal Error"
+
+
+get :: W.Middleware
+get app req resp
+ | W.requestMethod req == methodGet = app req resp
+ | otherwise = do
+ Log.warn $ "405 Method Not Allowed: " ++ showReq req
+ resp $ W.responseLBS methodNotAllowed405 [("Allow", "GET")] "Method Not Allowed"
+
+
+redirectURL :: W.Request -> Text -> ByteString
+redirectURL req provider =
+ "https://" <> fromJust (W.requestHeaderHost req)
+ <> "/.sproxy/oauth2/" <> encodeUtf8 provider
+
+
+-- XXX: make sure not to reveal the cookie, which can be valid (!)
+showReq :: W.Request -> String
+showReq req =
+ unpack ( W.requestMethod req <> " "
+ <> fromMaybe "<no host>" (W.requestHeaderHost req)
+ <> W.rawPathInfo req <> W.rawQueryString req <> " " )
+ ++ show (fromMaybe "-" $ W.requestHeaderReferer req) ++ " "
+ ++ show (fromMaybe "-" $ W.requestHeaderUserAgent req)
+ ++ " from " ++ show (W.remoteHost req)
+
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)
+
diff --git a/src/Sproxy/Config.hs b/src/Sproxy/Config.hs
new file mode 100644
index 0000000..30a8bae
--- /dev/null
+++ b/src/Sproxy/Config.hs
@@ -0,0 +1,88 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Sproxy.Config (
+ BackendConf(..)
+, ConfigFile(..)
+, OAuth2Conf(..)
+) where
+
+import Control.Applicative (empty)
+import Data.Aeson (FromJSON, parseJSON)
+import Data.HashMap.Strict (HashMap)
+import Data.Int (Int64)
+import Data.Text (Text)
+import Data.Word (Word16)
+import Data.Yaml (Value(Object), (.:), (.:?), (.!=))
+
+import Sproxy.Logging (LogLevel(Debug))
+
+data ConfigFile = ConfigFile {
+ cfListen :: Word16
+, cfUser :: String
+, cfHome :: FilePath
+, cfLogLevel :: LogLevel
+, cfSslCert :: FilePath
+, cfSslKey :: FilePath
+, cfSslCertChain :: [FilePath]
+, cfKey :: Maybe FilePath
+, cfListen80 :: Maybe Bool
+, cfBackends :: [BackendConf]
+, cfOAuth2 :: HashMap Text OAuth2Conf
+, cfDatabase :: Maybe String
+, cfPgPassFile :: Maybe FilePath
+, cfHTTP2 :: Bool
+} deriving (Show)
+
+instance FromJSON ConfigFile where
+ parseJSON (Object m) = ConfigFile <$>
+ m .:? "listen" .!= 443
+ <*> m .:? "user" .!= "sproxy"
+ <*> m .:? "home" .!= "."
+ <*> m .:? "log_level" .!= Debug
+ <*> m .: "ssl_cert"
+ <*> m .: "ssl_key"
+ <*> m .:? "ssl_cert_chain" .!= []
+ <*> m .:? "key"
+ <*> m .:? "listen80"
+ <*> m .: "backends"
+ <*> m .: "oauth2"
+ <*> m .:? "database"
+ <*> m .:? "pgpassfile"
+ <*> m .:? "http2" .!= True
+ parseJSON _ = empty
+
+
+data BackendConf = BackendConf {
+ beName :: String
+, beAddress :: String
+, bePort :: Maybe Word16
+, beSocket :: Maybe FilePath
+, beCookieName :: String
+, beCookieDomain :: Maybe String
+, beCookieMaxAge :: Int64
+, beConnCount :: Int
+} deriving (Show)
+
+instance FromJSON BackendConf where
+ parseJSON (Object m) = BackendConf <$>
+ m .:? "name" .!= "*"
+ <*> m .:? "address" .!= "127.0.0.1"
+ <*> m .:? "port"
+ <*> m .:? "socket"
+ <*> m .:? "cookie_name" .!= "sproxy"
+ <*> m .:? "cookie_domain"
+ <*> m .:? "cookie_max_age" .!= (7 * 24 * 60 * 60)
+ <*> m .:? "conn_count" .!= 32
+ parseJSON _ = empty
+
+
+data OAuth2Conf = OAuth2Conf {
+ oa2ClientId :: String
+, oa2ClientSecret :: FilePath
+} deriving (Show)
+
+instance FromJSON OAuth2Conf where
+ parseJSON (Object m) = OAuth2Conf <$>
+ m .: "client_id"
+ <*> m .: "client_secret"
+ parseJSON _ = empty
+
diff --git a/src/Sproxy/Logging.hs b/src/Sproxy/Logging.hs
new file mode 100644
index 0000000..651a73a
--- /dev/null
+++ b/src/Sproxy/Logging.hs
@@ -0,0 +1,99 @@
+module Sproxy.Logging (
+ LogLevel(..)
+, debug
+, error
+, info
+, level
+, start
+, warn
+) where
+
+import Prelude hiding (error)
+
+import Control.Applicative (empty)
+import Control.Concurrent (forkIO)
+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
+import Control.Monad (forever, when)
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Char (toLower)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import System.IO (hPrint, stderr)
+import System.IO.Unsafe (unsafePerformIO)
+import Text.Read (readMaybe)
+import qualified Data.Aeson as JSON
+import qualified Data.Text as T
+
+start :: LogLevel -> IO ()
+start None = return ()
+start lvl = do
+ writeIORef logLevel lvl
+ ch <- readIORef chanRef
+ _ <- forkIO . forever $ readChan ch >>= hPrint stderr
+ return ()
+
+info :: String -> IO ()
+info = send . Message Info
+
+warn:: String -> IO ()
+warn = send . Message Warning
+
+error:: String -> IO ()
+error = send . Message Error
+
+debug :: String -> IO ()
+debug = send . Message Debug
+
+
+send :: Message -> IO ()
+send msg@(Message l _) = do
+ lvl <- level
+ when (l <= lvl) $ do
+ ch <- readIORef chanRef
+ writeChan ch msg
+
+{-# NOINLINE chanRef #-}
+chanRef :: IORef (Chan Message)
+chanRef = unsafePerformIO (newChan >>= newIORef)
+
+{-# NOINLINE logLevel #-}
+logLevel :: IORef LogLevel
+logLevel = unsafePerformIO (newIORef None)
+
+level :: IO LogLevel
+level = readIORef logLevel
+
+
+data LogLevel = None | Error | Warning | Info | Debug
+ deriving (Enum, Ord, Eq)
+
+instance Show LogLevel where
+ show None = "NONE"
+ show Error = "ERROR"
+ show Warning = "WARN"
+ show Info = "INFO"
+ show Debug = "DEBUG"
+
+instance Read LogLevel where
+ readsPrec _ s
+ | l == "none" = [ (None, "") ]
+ | l == "error" = [ (Error, "") ]
+ | l == "warn" = [ (Warning, "") ]
+ | l == "info" = [ (Info, "") ]
+ | l == "debug" = [ (Debug, "") ]
+ | otherwise = [ ]
+ where l = map toLower s
+
+instance ToJSON LogLevel where
+ toJSON = JSON.String . T.pack . show
+
+instance FromJSON LogLevel where
+ parseJSON (JSON.String s) =
+ maybe (fail $ "unknown log level: " ++ show s) return (readMaybe . T.unpack $ s)
+ parseJSON _ = empty
+
+
+data Message = Message LogLevel String
+
+instance Show Message where
+ show (Message lvl str) = show lvl ++ ": " ++ str
+
diff --git a/src/Sproxy/Server.hs b/src/Sproxy/Server.hs
new file mode 100644
index 0000000..bd2af17
--- /dev/null
+++ b/src/Sproxy/Server.hs
@@ -0,0 +1,190 @@
+module Sproxy.Server (
+ server
+) where
+
+import Control.Concurrent (forkIO)
+import Control.Exception (bracketOnError)
+import Control.Monad (void, when)
+import Data.ByteString as BS (hGetLine, readFile)
+import Data.ByteString.Char8 (pack)
+import Data.HashMap.Strict as HM (fromList, lookup, toList)
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import Data.Word (Word16)
+import Data.Yaml (decodeFileEither)
+import Network.HTTP.Client (Manager, ManagerSettings(..), defaultManagerSettings, newManager, socketConnection)
+import Network.HTTP.Client.Internal (Connection)
+import Network.Socket ( Family(AF_INET, AF_UNIX), SockAddr(SockAddrInet, SockAddrUnix),
+ SocketOption(ReuseAddr), SocketType(Stream), bind, close, connect, inet_addr,
+ listen, maxListenQueue, setSocketOption, socket )
+import Network.Wai.Handler.WarpTLS (tlsSettingsChain, runTLSSocket)
+import Network.Wai.Handler.Warp (defaultSettings, setHTTP2Disabled, runSettingsSocket)
+import System.Entropy (getEntropy)
+import System.Environment (setEnv)
+import System.Exit (exitFailure)
+import System.FilePath.Glob (compile)
+import System.IO (IOMode(ReadMode), hIsEOF, hPutStrLn, stderr, withFile)
+import System.Posix.User ( GroupEntry(..), UserEntry(..),
+ getAllGroupEntries, getRealUserID,
+ getUserEntryForName, setGroupID, setGroups, setUserID )
+
+import Sproxy.Application (sproxy, redirect)
+import Sproxy.Application.OAuth2.Common (OAuth2Client)
+import Sproxy.Config (BackendConf(..), ConfigFile(..), OAuth2Conf(..))
+import qualified Sproxy.Application.OAuth2 as OAuth2
+import qualified Sproxy.Logging as Log
+import qualified Sproxy.Server.DB as DB
+
+
+server :: FilePath -> IO ()
+server configFile = do
+ cf <- readConfigFile configFile
+ Log.start $ cfLogLevel cf
+ Log.debug $ show cf
+
+ sock <- socket AF_INET Stream 0
+ setSocketOption sock ReuseAddr 1
+ bind sock $ SockAddrInet (fromIntegral $ cfListen cf) 0
+
+ maybe80 <- if fromMaybe (443 == cfListen cf) (cfListen80 cf)
+ then do
+ sock80 <- socket AF_INET Stream 0
+ setSocketOption sock80 ReuseAddr 1
+ bind sock80 $ SockAddrInet 80 0
+ return (Just sock80)
+ else
+ return Nothing
+
+ uid <- getRealUserID
+ when (0 == uid) $ do
+ let user = cfUser cf
+ Log.info $ "switching to user " ++ show user
+ u <- getUserEntryForName user
+ groupIDs <- map groupID . filter (elem user . groupMembers)
+ <$> getAllGroupEntries
+ setGroups groupIDs
+ setGroupID $ userGroupID u
+ setUserID $ userID u
+
+ case cfPgPassFile cf of
+ Nothing -> return ()
+ Just f -> do
+ Log.info $ "pgpassfile: " ++ show f
+ setEnv "PGPASSFILE" f
+
+ db <- DB.start (cfHome cf) (newDataSource cf)
+
+ key <- maybe
+ (Log.info "using new random key" >> getEntropy 32)
+ (\f -> Log.info ("reading key from " ++ f) >> BS.readFile f)
+ (cfKey cf)
+
+ case maybe80 of
+ Nothing -> return ()
+ Just sock80 -> do
+ Log.info "listening on port 80 (HTTP redirect)"
+ listen sock80 maxListenQueue
+ void . forkIO $ runSettingsSocket defaultSettings sock80 (redirect $ cfListen cf)
+
+ oauth2clients <- HM.fromList <$> mapM newOAuth2Client (HM.toList (cfOAuth2 cf))
+
+ backends <-
+ mapM (\be -> do
+ m <- newBackendManager be
+ return (compile $ beName be, be, m)
+ ) $ cfBackends cf
+
+ let
+ settings =
+ (if cfHTTP2 cf then id else setHTTP2Disabled)
+ defaultSettings
+
+ -- XXX 2048 is from bindPortTCP from streaming-commons used internally by runTLS.
+ -- XXX Since we don't call runTLS, we listen socket here with the same options.
+ Log.info $ "listening on port " ++ show (cfListen cf) ++ " (HTTPS)"
+ listen sock (max 2048 maxListenQueue)
+ runTLSSocket
+ (tlsSettingsChain (cfSslCert cf) (cfSslCertChain cf) (cfSslKey cf))
+ settings
+ sock
+ (sproxy key db oauth2clients backends)
+
+
+newDataSource :: ConfigFile -> Maybe DB.DataSource
+newDataSource cf =
+ case cfDatabase cf of
+ Just str -> Just $ DB.PostgreSQL str
+ Nothing -> Nothing
+
+
+newOAuth2Client :: (Text, OAuth2Conf) -> IO (Text, OAuth2Client)
+newOAuth2Client (name, cfg) =
+ case HM.lookup name OAuth2.providers of
+ Nothing -> do Log.error $ "OAuth2 provider " ++ show name ++ " is not supported"
+ exitFailure
+ Just provider -> do
+ Log.info $ "oauth2: adding " ++ show name
+ client_secret <- withFile secret_file ReadMode $ \h -> do
+ empty <- hIsEOF h
+ if empty then do
+ Log.error $ "oauth2: empty secret file for "
+ ++ show name ++ ": " ++ show secret_file
+ return $ pack ""
+ else BS.hGetLine h
+ return (name, provider (pack client_id, client_secret))
+ where client_id = oa2ClientId cfg
+ secret_file = oa2ClientSecret cfg
+
+
+newBackendManager :: BackendConf -> IO Manager
+newBackendManager be = do
+ openConn <-
+ case (beSocket be, bePort be) of
+ (Just f, Nothing) -> do
+ Log.info $ "backend `" ++ beName be ++ "' on UNIX socket " ++ f
+ return $ openUnixSocketConnection f
+
+ (Nothing, Just n) -> do
+ Log.info $ "backend `" ++ beName be ++ "' on " ++ beAddress be ++ ":" ++ show n
+ return $ openTCPConnection (beAddress be) n
+
+ _ -> do
+ Log.error "either backend port number or UNIX socket path is required."
+ exitFailure
+
+ newManager defaultManagerSettings {
+ managerRawConnection = return $ \_ _ _ -> openConn
+ , managerConnCount = beConnCount be
+ }
+
+
+openUnixSocketConnection :: FilePath -> IO Connection
+openUnixSocketConnection f =
+ bracketOnError
+ (socket AF_UNIX Stream 0)
+ close
+ (\s -> do
+ connect s (SockAddrUnix f)
+ socketConnection s 8192)
+
+
+openTCPConnection :: String -> Word16 -> IO Connection
+openTCPConnection addr port =
+ bracketOnError
+ (socket AF_INET Stream 0)
+ close
+ (\s -> do
+ a <- inet_addr addr
+ connect s (SockAddrInet (fromIntegral port) a)
+ socketConnection s 8192)
+
+
+readConfigFile :: FilePath -> IO ConfigFile
+readConfigFile f = do
+ r <- decodeFileEither f
+ case r of
+ Left e -> do
+ hPutStrLn stderr $ "FATAL: " ++ f ++ ": " ++ show e
+ exitFailure
+ Right cf -> return cf
+
diff --git a/src/Sproxy/Server/DB.hs b/src/Sproxy/Server/DB.hs
new file mode 100644
index 0000000..b760afc
--- /dev/null
+++ b/src/Sproxy/Server/DB.hs
@@ -0,0 +1,189 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+module Sproxy.Server.DB (
+ Database
+, DataSource(..)
+, userExists
+, userGroups
+, start
+) where
+
+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
+import qualified Database.SQLite.Simple as SQLite
+
+import qualified Sproxy.Logging as Log
+
+
+type Database = Pool SQLite.Connection
+
+data DataSource = PostgreSQL String -- | File FilePath
+
+{- TODO:
+ - Hash remote tables and update the local only when the remote change
+ - Switch to REGEX
+ - Generalize sync procedures for different tables
+ -}
+
+start :: FilePath -> Maybe DataSource -> IO Database
+start home ds = do
+ Log.info $ "home directory: " ++ show home
+ db <- createPool
+ (do c <- SQLite.open $ home ++ "/sproxy.sqlite3"
+ lvl <- Log.level
+ SQLite.setTrace c (if lvl == Log.Debug then Just $ Log.debug . unpack else Nothing)
+ return c)
+ SQLite.close
+ 1 -- stripes
+ 3600 -- keep alive (seconds). FIXME: no much sense as it's a local file
+ 128 -- max connections. FIXME: make configurable?
+
+ withResource db $ \c -> SQLite.execute_ c "PRAGMA journal_mode=WAL"
+ populate db ds
+ return db
+
+
+userExists :: Database -> String -> 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)"
+ [ ":email" := email ]
+ return $ head r
+
+
+userGroups :: Database -> String -> Text -> Text -> Text -> IO [ByteString]
+userGroups db email domain path method =
+ withResource db $ \c -> fmap (encodeUtf8 . 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
+ AND gp.privilege IN (
+ SELECT privilege FROM privilege_rule
+ WHERE :domain LIKE domain
+ AND :path LIKE path
+ AND method = :method
+ ORDER BY length(path) - length(replace(path, '/', '')) DESC LIMIT 1
+ )
+ |] [ ":email" := email -- XXX always in lower case
+ , ":domain" := toLower domain
+ , ":path" := path
+ , ":method" := method -- XXX case-sensitive by RFC2616
+ ]
+
+
+populate :: Database -> Maybe DataSource -> IO ()
+
+populate db Nothing = do
+ Log.warn "db: no data source defined"
+ withResource db $ \c -> SQLite.withTransaction c $ do
+ createGroupMember c
+ createGroupPrivilege c
+ createPrivilegeRule c
+
+-- XXX We keep only required minimum of the data, without any integrity check.
+-- XXX Integrity check should be done somewhere else, e. g. in the master PostgreSQL database,
+-- XXX or during importing the config file.
+populate db (Just (PostgreSQL connstr)) =
+ void . forkIO . forever . flip finally (7 `minutes` threadDelay)
+ . logException $ do
+ Log.info $ "db: synchronizing with " ++ show connstr
+ withResource db $ \c -> SQLite.withTransaction c $
+ bracket (PG.connectPostgreSQL $ pack connstr) PG.close $
+ \pg -> PG.withTransaction pg $ do
+
+ Log.info "db: syncing group_member"
+ dropGroupMember c
+ createGroupMember c
+ PG.forEach_ pg
+ [q|SELECT "group", lower(email) FROM group_member|] $ \r ->
+ SQLite.execute c
+ [q|INSERT INTO group_member("group", email) VALUES (?, ?)|]
+ (r :: (Text, Text))
+ count c "group_member"
+
+ Log.info "db: syncing group_privilege"
+ dropGroupPrivilege c
+ createGroupPrivilege c
+ PG.forEach_ pg
+ [q|SELECT "group", lower(domain), privilege FROM group_privilege|] $ \r ->
+ SQLite.execute c
+ [q|INSERT INTO group_privilege("group", domain, privilege) VALUES (?, ?, ?)|]
+ (r :: (Text, Text, Text))
+ count c "group_privilege"
+
+ Log.info "db: syncing privilege_rule"
+ dropPrivilegeRule c
+ createPrivilegeRule c
+ PG.forEach_ pg
+ [q|SELECT lower(domain), privilege, path, method FROM privilege_rule|] $ \r ->
+ SQLite.execute c
+ [q|INSERT INTO privilege_rule(domain, privilege, path, method) VALUES (?, ?, ?, ?)|]
+ (r :: (Text, Text, Text, Text))
+ count c "privilege_rule"
+
+
+dropGroupMember :: SQLite.Connection -> IO ()
+dropGroupMember c = SQLite.execute_ c "DROP TABLE IF EXISTS group_member"
+
+createGroupMember :: SQLite.Connection -> IO ()
+createGroupMember c = SQLite.execute_ c [q|
+ CREATE TABLE IF NOT EXISTS group_member (
+ "group" TEXT,
+ email TEXT,
+ PRIMARY KEY ("group", email)
+ )
+|]
+
+
+dropGroupPrivilege :: SQLite.Connection -> IO ()
+dropGroupPrivilege c = SQLite.execute_ c "DROP TABLE IF EXISTS group_privilege"
+
+createGroupPrivilege :: SQLite.Connection -> IO ()
+createGroupPrivilege c = SQLite.execute_ c [q|
+ CREATE TABLE IF NOT EXISTS group_privilege (
+ "group" TEXT,
+ domain TEXT,
+ privilege TEXT,
+ PRIMARY KEY ("group", domain, privilege)
+ )
+|]
+
+
+dropPrivilegeRule :: SQLite.Connection -> IO ()
+dropPrivilegeRule c = SQLite.execute_ c "DROP TABLE IF EXISTS privilege_rule"
+
+createPrivilegeRule :: SQLite.Connection -> IO ()
+createPrivilegeRule c = SQLite.execute_ c [q|
+ CREATE TABLE IF NOT EXISTS privilege_rule (
+ domain TEXT,
+ privilege TEXT,
+ path TEXT,
+ method TEXT,
+ PRIMARY KEY (domain, path, method)
+ )
+|]
+
+
+count :: SQLite.Connection -> String -> IO ()
+count c table = do
+ r <- fmap SQLite.fromOnly <$> SQLite.query_ c [qc|SELECT COUNT(*) FROM {table}|]
+ Log.info $ "db: " ++ table ++ " rows: " ++ show (head r :: Integer)
+
+
+logException :: IO () -> IO ()
+logException a = catch a $ \e ->
+ Log.error $ "db: " ++ show (e :: SomeException)
+
+
+minutes :: Int -> (Int -> IO ()) -> IO ()
+minutes us f = f $ us * 60 * 1000000
+
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-21 19:56:30 +0000