sproxy2 (empty) → 1.90.0

raw patch · 19 files changed

+1872/−0 lines, 19 filesdep +Globdep +SHAdep +aesonsetup-changed

Dependencies added: Glob, SHA, aeson, base, base64-bytestring, blaze-builder, bytestring, cereal, conduit, containers, cookie, docopt, entropy, http-client, http-conduit, http-types, interpolatedstring-perl6, network, postgresql-simple, resource-pool, sqlite-simple, text, time, unix, unordered-containers, wai, wai-conduit, warp, warp-tls, word8, yaml

Files

ChangeLog.md +43/−0
LICENSE +20/−0
README.md +161/−0
Setup.hs +2/−0
sproxy.sql +168/−0
sproxy.yml.example +139/−0
sproxy2.cabal +72/−0
src/Main.hs +37/−0
src/Sproxy/Application.hs +372/−0
src/Sproxy/Application/Cookie.hs +44/−0
src/Sproxy/Application/OAuth2.hs +18/−0
src/Sproxy/Application/OAuth2/Common.hs +39/−0
src/Sproxy/Application/OAuth2/Google.hs +78/−0
src/Sproxy/Application/OAuth2/LinkedIn.hs +83/−0
src/Sproxy/Application/State.hs +30/−0
src/Sproxy/Config.hs +88/−0
src/Sproxy/Logging.hs +99/−0
src/Sproxy/Server.hs +190/−0
src/Sproxy/Server/DB.hs +189/−0

+ ChangeLog.md view

@@ -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)+

+ LICENSE view

@@ -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.

+ README.md view

@@ -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+```+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ sproxy.sql view

@@ -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;+

+ sproxy.yml.example view

@@ -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+

+ sproxy2.cabal view

@@ -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+

+ src/Main.hs view

@@ -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+

+ src/Sproxy/Application.hs view

@@ -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)+

@@ -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++

+ src/Sproxy/Application/OAuth2.hs view

@@ -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)+  ]+

+ src/Sproxy/Application/OAuth2/Common.hs view

@@ -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+

+ src/Sproxy/Application/OAuth2/Google.hs view

@@ -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+

+ src/Sproxy/Application/OAuth2/LinkedIn.hs view

@@ -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+

+ src/Sproxy/Application/State.hs view

@@ -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)+

+ src/Sproxy/Config.hs view

@@ -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+

+ src/Sproxy/Logging.hs view

@@ -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+

+ src/Sproxy/Server.hs view

@@ -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+

+ src/Sproxy/Server/DB.hs view

@@ -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+