├── .gitignore
├── .hindent.yaml
├── ChangeLog.md
├── LICENSE
├── README.md
├── Setup.hs
├── datafile.example.yml
├── sproxy.example.yml
├── sproxy.sql
├── sproxy2.cabal
├── src
    ├── Main.hs
    └── Sproxy
    │   ├── Application.hs
    │   ├── Application
    │       ├── Access.hs
    │       ├── Cookie.hs
    │       ├── OAuth2.hs
    │       ├── OAuth2
    │       │   ├── Common.hs
    │       │   ├── Google.hs
    │       │   ├── LinkedIn.hs
    │       │   └── Yandex.hs
    │       └── State.hs
    │   ├── Config.hs
    │   ├── Logging.hs
    │   ├── Server.hs
    │   └── Server
    │       ├── DB.hs
    │       └── DB
    │           └── DataFile.hs
└── stack.yaml


/.gitignore:
--------------------------------------------------------------------------------
1 | *.sqlite3*
2 | *.swp
3 | /.cabal-sandbox/
4 | /.stack-work
5 | /cabal-dev/
6 | /cabal.sandbox.config
7 | /dist/
8 | sproxy.yml
9 | 


--------------------------------------------------------------------------------
/.hindent.yaml:
--------------------------------------------------------------------------------
1 | indent-size: 2
2 | line-length: 80
3 | force-trailing-newline: true
4 | 


--------------------------------------------------------------------------------
/ChangeLog.md:
--------------------------------------------------------------------------------
  1 | For differences with the original Sproxy scroll down.
  2 | 
  3 | 1.96.0
  4 | ======
  5 | 
  6 |   * Added support for Yandex (https://tech.yandex.com/oauth/).
  7 | 
  8 |   * Encode full URL (including protocol) into the state parameter,
  9 |     not just path.  This makes it possible to work with OAuth2 providers
 10 |     that do not support multiple callback URL, like Yandex.
 11 | 
 12 |   * Fixed POST requests for tokens with Google and LinkedIn. They
 13 |     were mistakenly using URL paramaters instead of URL-encoded bodies.
 14 | 
 15 | 
 16 | 1.95.0
 17 | ======
 18 | 
 19 |   * Add end-point for checking access in a bunch (`/.sproxy/access`).
 20 | 
 21 |   * Respond with 502 (Bad Gateway) on any backend error.
 22 |     Previously it was 500 (Internal Server Error).
 23 | 
 24 | 
 25 | 1.94.1
 26 | ======
 27 | 
 28 |   * Fixed a typo introduced in version 1.94.0 in SQL query:
 29 |     `... WHERE domain = domain ...` -> `... WHERE domain = :domain ...`
 30 | 
 31 | 
 32 | 1.94.0
 33 | ======
 34 | 
 35 |   * BREAKING: Disregard possible port in the Host HTTP header.
 36 |     Previously, Sproxy took possible port number into account when
 37 |     looking for backend and privileges. Now it ignores port and considers
 38 |     domain name only.  This also gets Sproxy in line with browsers and SSL
 39 |     certificates: certificates do not include port numbers, browsers ignore
 40 |     ports when sending cookies.
 41 | 
 42 |   * BREAKING: no SQL wildcards (`%` or `_`) in domain names when looking up
 43 |     for privileges.  This feature was ambiguous (in the same way as paths are)
 44 |     and never used anyway.
 45 | 
 46 | 
 47 | 1.93.0
 48 | ======
 49 | 
 50 |   * BREAKING: Allow `!include` in config file.
 51 |     This changes semantics of options `key` and `oauth2.<provider>.client_secret`.
 52 |     They are no longer files, but strings.  To read content from files, use
 53 |     !include.  The point of being files or read from files is to segregate secrets
 54 |     from non-sensitive easily discoverable settings.  With `!include` it is much more
 55 |     simple and flexible.
 56 | 
 57 | 
 58 | 1.92.0
 59 | ======
 60 | 
 61 |   * Allow running in plain HTTP mode (no SSL). Useful when Sproxy is behind some
 62 |     other proxy or load-balancer. Added two more options: `ssl` (defaults to true)
 63 |     and `https_port` (defaults to like `listen`). Options `ssl_key` and `ssl_cert`
 64 |     are required only if `ssl == true`. SSL-terminations is still required at upstream
 65 |     proxies, because the cookie is set for HTTPS only.
 66 | 
 67 |   * Added "user" table into `sproxy.sql`. No action is required, but PostgreSQL database
 68 |     built after this file will be incompatible with Sproxy Web ( <= 0.4.1 at least).
 69 | 
 70 | 
 71 | 1.91.0
 72 | ======
 73 | 
 74 |   * In addition to good old PostgreSQL data source, made it possible
 75 |     to import permission data from a YAML file. This means that Sproxy2
 76 |     can work without any PostgreSQL database, just using file-only configuration.
 77 |     Useful for development or trivial deployments. Added new `datafile` option
 78 |     in configuration file.
 79 | 
 80 | 
 81 | 1.90.2
 82 | ======
 83 | 
 84 |   * Make sure all Sproxy-specific HTTP headers are UTF8-encoded.
 85 | 
 86 |   * `/.sproxy/logout` just redirects if no cookie. Previously
 87 |     it was returning HTTP 404 to unauthenticated users, and redirecting
 88 |     authenticated users with removal of the cookie. The point is not to
 89 |     reveal cookie name.
 90 | 
 91 |   * Made Warp stop printing exceptions, mostly "client closed connection",
 92 |     which happens outside of our traps.
 93 | 
 94 | 
 95 | 1.90.1
 96 | ======
 97 | 
 98 |   * Fixed headers processing. Wrong headers were making Chromium drop connection in HTTP/2.
 99 |     Firefox sometimes couldn't handle gzipped and chunked responses in HTTP/1.1.
100 | 
101 |   * After authenticating, redirect to original path with query parameters if
102 |     method was GET.  Otherwise redirect to "/". Previously, when unauthenticated
103 |     users click on "https://example.net/foo?bar", they are redirected to
104 |     "https://example.net/foo" regardless of the method.
105 | 
106 | 
107 | 
108 | 1.90.0 (Preview Release)
109 | ========================
110 | 
111 | Sproxy2 is overhaul of original [Sproxy](https://github.com/zalora/sproxy)
112 | (see also [Hackage](https://hackage.haskell.org/package/sproxy)).
113 | Here are the key differences (with Sproxy 0.9.8):
114 | 
115 |   * Sproxy2 can work with remote PostgreSQL database. Quick access to the database is essential
116 |     as sproxy does it on every HTTP request. Sproxy2 pulls data into local SQLite3 database.
117 | 
118 |   * At this release Sproxy2 is compatible with Sproxy database with one exception:
119 |     SQL wildcards are not supported for HTTP methods. I. e. you have to change '%' in
120 |     the database to specific methods like GET, POST, etc.
121 | 
122 |   * OAuth2 callback URLs changed: Sproxy2 uses `/.sproxy/oauth2/:provider`,
123 |     e. g. `/.sproxy/oauth2/google`. Sproxy used `/sproxy/oauth2callback` for Google
124 |     and `/sproxy/oauth2callback/linkedin` for LinkedIn.
125 | 
126 |   * Sproxy2 does not allow login with email addresses not known to it.
127 | 
128 |   * Sproxy2: OAuth2 callback state is serialized, signed and passed base64-encoded.
129 |     Of course it's used to verify the request is legit.
130 | 
131 |   * Sproxy2: session cookie is serialized, signed and sent base64-encoded.
132 | 
133 |   * Path `/.sproxy` belongs to Sproxy2 completely. Anything under this path is never passed to backends.
134 | 
135 |   * Sproxy2 supports multiple backends. Routing is based on the Host HTTP header.
136 | 
137 |   * Sproxy2 uses [WAI](https://hackage.haskell.org/package/wai) / [Warp](https://hackage.haskell.org/package/warp)
138 |     for incoming connections. As a result Sproxy2 supports HTTP2.
139 | 
140 |   * Sproxy2 uses [HTTP Client](https://hackage.haskell.org/package/http-client) to talk to backends.
141 |     As a result Sproxy2 reuses backend connections instead of closing them after each request to the backend.
142 | 
143 |   * Sproxy2 optionally supports persistent key again (removed in Sproxy 0.9.2).
144 |     This can be used in load-balancing multiple Sproxy2 instances.
145 | 
146 |   * Configuration file has changed. It's still YAML, but some options are renamed, removed or added.
147 |     Have a look at well-documented [sproxy.example.yml](./sproxy.example.yml)
148 | 
149 | 


--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
 1 | Copyright (c) 2016, Zalora South East Asia Pte. Ltd
 2 | Copyright (c) 2017, Igor Pashev <pashev.igor@gmail.com>
 3 | 
 4 | Permission is hereby granted, free of charge, to any person obtaining
 5 | a copy of this software and associated documentation files (the
 6 | "Software"), to deal in the Software without restriction, including
 7 | without limitation the rights to use, copy, modify, merge, publish,
 8 | distribute, sublicense, and/or sell copies of the Software, and to
 9 | permit persons to whom the Software is furnished to do so, subject to
10 | the following conditions:
11 | 
12 | The above copyright notice and this permission notice shall be included
13 | in all copies or substantial portions of the Software.
14 | 
15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
16 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
17 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
18 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
19 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
20 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
21 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # Sproxy2
  2 | 
  3 | HTTP proxy for authenticating users via OAuth2.
  4 | 
  5 | 
  6 | ## Motivation
  7 | 
  8 | This is overhaul of original [Sproxy](https://hackage.haskell.org/package/sproxy).
  9 | See [ChangeLog.md](./ChangeLog.md) for the differences.
 10 | 
 11 | Why use a proxy for doing OAuth2? Isn't that up to the application?
 12 | 
 13 |  * sproxy is secure by default.  No requests make it to
 14 |    the web server if they haven't been explicitly whitelisted.
 15 |  * sproxy is independent.  Any web application written in
 16 |    any language can use it.
 17 | 
 18 | ## Use cases
 19 | 
 20 |  * Existing web applications with concept of roles. For example,
 21 |    [Mediawiki](https://www.mediawiki.org), [Jenkins](https://jenkins.io),
 22 |    [Icinga Web 2](https://www.icinga.org/products/icinga-web-2/). In
 23 |    this case you configure Sproxy to allow unrestricted access
 24 |    to the application for some groups defined by Sproxy. These
 25 |    groups are mapped to the application roles.  There is a [plugin for
 26 |    Jenkins](https://wiki.jenkins-ci.org/display/JENKINS/Reverse+Proxy+Auth+Plugin)
 27 |    which can be used for this. Mediawiki and Icinga Web 2 were also
 28 |    successfully deployed in this way, though it required changes to their
 29 |    source code.
 30 | 
 31 |  * New web applications designed to work specifically behind Sproxy. In this case
 32 |    you define Sproxy rules to control access to the
 33 |    application's API.  It would likely be [a single-page
 34 |    application](https://en.wikipedia.org/wiki/Single-page_application).
 35 |    Examples are [MyWatch](https://hackage.haskell.org/package/mywatch) and
 36 |    [Juan de la Cosa](https://hackage.haskell.org/package/juandelacosa).
 37 | 
 38 |  * Replace HTTP Basic authentication.
 39 | 
 40 | 
 41 | How it works
 42 | ============
 43 | 
 44 | When an HTTP client makes a request, Sproxy checks for a *session cookie*.
 45 | If it doesn't exist (or it's invalid, expired), it responses with [HTTP
 46 | status 511](https://tools.ietf.org/html/rfc6585) with the page, where the
 47 | user can choose an [OAuth2](https://tools.ietf.org/html/rfc6749) provider to
 48 | authenticate with.  Finally, we store the the email address in a session
 49 | cookie: signed with a hash to prevent tampering, set for HTTP only (to prevent
 50 | malicious JavaScript from reading it), and set it for secure (since we don't
 51 | want it traveling over plaintext HTTP connections).
 52 | 
 53 | From that point on, when sproxy detects a valid session cookie it extracts the
 54 | email, checks it against the access rules, and relays the request to the
 55 | back-end server (if allowed).
 56 | 
 57 | 
 58 | Permissions system
 59 | ------------------
 60 | Permissions are stored in internal SQLite3 database and imported
 61 | from data sources, which can be a PostgreSQL database or a file.  See
 62 | [sproxy.sql](./sproxy.sql) and [datafile.example.yml](./datafile.example.yml)
 63 | for details.
 64 | 
 65 | Do note that Sproxy2 fetches only `group_member`, `group_privilege`
 66 | and `privilege_rule` tables, because only these tables are used for
 67 | authorization. The other tables in PostgreSQL schema serve for data
 68 | integrity. Data integrity of the data file is not verfied, though import
 69 | may fail due to primary key restrictions.
 70 | 
 71 | Only one data source can be used. The data in internal database, if any,
 72 | is fully overwritten by the data from a data source. If no data source is
 73 | specified, the data in internal database remains unchanged, even between
 74 | restarts.  Broken data source is _not_ fatal. Sproxy will keep using existing
 75 | internal database, or create a new empty one if missed. Broken data source
 76 | means inability to connect to PostgreSQL database, missed datafile, etc.
 77 | 
 78 | The data from a PostgreSQL database are periodically fetched into the internal
 79 | database, while the data file is read once at startup.
 80 | 
 81 | Here are the main concepts:
 82 | 
 83 | - A `group` is identified by a name. Every group has
 84 |   - members (identified by email address, through `group_member`) and
 85 |   - associated privileges (through `group_privilege`).
 86 | - A `privilege` is identified by a name _and_ a domain. It has associated rules
 87 |   (through `privilege_rule`) that define what the privilege gives access to.
 88 | - A `rule` is a combination of sql patterns for a `domain`, a `path` and an
 89 |   HTTP `method`. A rule matches an HTTP request, if all of these components
 90 |   match the respective attributes of the request. However of all the matching
 91 |   rules only the rule with the longest `path` pattern will be used to determine
 92 |   whether a user is allowed to perform a request. This is often a bit
 93 |   surprising, please see the following example:
 94 | 
 95 | 
 96 | Privileges example
 97 | ------------------
 98 | 
 99 | Consider this `group_privilege` and `privilege_rule` relations:
100 | 
101 | group            | privilege | domain
102 | ---------------- | --------- | -----------------
103 | `readers`        | `basic`   | `wiki.example.com`
104 | `readers`        | `read`    | `wiki.example.com`
105 | `editors`        | `basic`   | `wiki.example.com`
106 | `editors`        | `read`    | `wiki.example.com`
107 | `editors`        | `edit`    | `wiki.example.com`
108 | `administrators` | `basic`   | `wiki.example.com`
109 | `administrators` | `read`    | `wiki.example.com`
110 | `administrators` | `edit`    | `wiki.example.com`
111 | `administrators` | `admin`   | `wiki.example.com`
112 | 
113 | privilege   | domain             | path           | method
114 | ----------- | ------------------ | -------------- | ------
115 | `basic`     | `wiki.example.com` | `/%`           | `GET`
116 | `read`      | `wiki.example.com` | `/wiki/%`      | `GET`
117 | `edit`      | `wiki.example.com` | `/wiki/edit/%` | `GET`
118 | `edit`      | `wiki.example.com` | `/wiki/edit/%` | `POST`
119 | `admin`     | `wiki.example.com` | `/admin/%`     | `GET`
120 | `admin`     | `wiki.example.com` | `/admin/%`     | `POST`
121 | `admin`     | `wiki.example.com` | `/admin/%`     | `DELETE`
122 | 
123 | With this setup, everybody (that is `readers`, `editors` and `administrators`s)
124 | will have access to e.g. `/imgs/logo.png` and `/favicon.ico`, but only
125 | administrators will have access to `/admin/index.php`, because the longest
126 | matching path pattern is `/admin/%` and only `administrator`s have the `admin`
127 | privilege.
128 | 
129 | Likewise `readers` have no access to e.g. `/wiki/edit/delete_everything.php`.
130 | 
131 | 
132 | Keep in mind that:
133 | 
134 | - Domains are converted into lower case (coming from a data source or HTTP requests).
135 | - Emails are converted into lower case (coming from a data source or OAuth2 providers).
136 | - Groups are case-sensitive and treated as is.
137 | - HTTP methods are *case-sensitive*.
138 | - HTTP query parameters are ignored when matching a request against the rules.
139 | - Privileges are case-sensitive and treated as is.
140 | - SQL wildcards (`_` and `%`) are supported for emails, paths (this _will_ change in future versions).
141 | 
142 | 
143 | Checking access in a bunch
144 | --------------------------
145 | 
146 | There is an API end-point for checking access rights in a single POST query:
147 | `/.sproxy/access`.  Users should be authenticated to use this end-point,
148 | otherwise the respond will be HTTP 511.
149 | 
150 | The request body shall be a JSON object like this:
151 | 
152 | ```json
153 | {
154 |   "tag1": {"path": "/foo", "method": "GET"},
155 |   "tag2": {"path": "/bar", "method": "GET"}
156 | }
157 | ```
158 | 
159 | And the respond will contain a JSON array with tag matching path and method
160 | pairs allowed to the user.  For example:
161 | 
162 | ```sh
163 | $ curl -d '{"foo": {"path":"/get", "method":"GET"}, "bar": {"path":"/post", "method":"POST"}}' -XPOST -k 'https://example.ru:8443/.sproxy/access' ...
164 | ["foo","bar"]
165 | 
166 | $ curl -d '{"foo": {"path":"/get", "method":"POST"}, "bar": {"path":"/post", "method":"POST"}}' -XPOST -k 'https://example.ru:8443/.sproxy/access' ...
167 | ["bar"]
168 | 
169 | $ curl -d '{"foo": {"path":"/", "method":"POST"}, "bar": {"path":"/post", "method":"GET"}}' -XPOST -k 'https://example.ru:8443/.sproxy/access' ...
170 | []
171 | 
172 | ```
173 | 
174 | 
175 | Logout
176 | ------
177 | 
178 | Hitting the endpoint `/.sproxy/logout` will invalidate the session cookie.
179 | The user will be redirected to `/` after logout.
180 | 
181 | 
182 | Robots
183 | ------
184 | 
185 | Since all sproxied resources are private, it doesn't make sense for web
186 | crawlers to try to index them. In fact, crawlers will index only the login
187 | page. To prevent this, sproxy returns the following for `/robots.txt`:
188 | 
189 | ```
190 | User-agent: *
191 | Disallow: /
192 | ```
193 | 
194 | 
195 | HTTP headers passed to the back-end server
196 | ------------------------------------------
197 | 
198 | All Sproxy headers are UTF8-encoded.
199 | 
200 | 
201 | header               | value
202 | -------------------- | -----
203 | `From:`              | visitor's email address, lower case
204 | `X-Groups:`          | all groups that granted access to this resource, separated by commas (see the note below)
205 | `X-Given-Name:`      | the visitor's given (first) name
206 | `X-Family-Name:`     | the visitor's family (last) name
207 | `X-Forwarded-Proto:` | the visitor's protocol of an HTTP request, always `https`
208 | `X-Forwarded-For`    | the visitor's IP address (added to the end of the list if header is already present in client request)
209 | 
210 | 
211 | `X-Groups` denotes an intersection of the groups the visitor belongs to and the groups that granted access:
212 | 
213 | Visitor's groups | Granted groups | `X-Groups`
214 | ---------------- | -------------- | ---------
215 | all              | all, devops    | all
216 | all, devops      | all            | all
217 | all, devops      | all, devops    | all,devops
218 | all, devops      | devops         | devops
219 | devops           | all, devops    | devops
220 | devops           | all            | Access denied
221 | 
222 | 
223 | Requirements
224 | ============
225 | Sproxy2 is written in Haskell with [GHC](http://www.haskell.org/ghc/).
226 | All required Haskell libraries are listed in [sproxy2.cabal](sproxy2.cabal).
227 | Use [cabal-install](http://www.haskell.org/haskellwiki/Cabal-Install)
228 | to fetch and build all pre-requisites automatically.
229 | 
230 | 
231 | Configuration
232 | =============
233 | 
234 | By default `sproxy2` will read its configuration from `sproxy.yml`.  There is
235 | example file with documentation [sproxy.example.yml](sproxy.example.yml). You
236 | can specify a custom path with:
237 | 
238 | ```
239 | sproxy2 --config /path/to/sproxy.yml
240 | ```
241 | 
242 | 


--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 | 


--------------------------------------------------------------------------------
/datafile.example.yml:
--------------------------------------------------------------------------------
 1 | group_member:
 2 |   - group: "devops"
 3 |     email: "%"
 4 | 
 5 |   - group: "foo"
 6 |     email: "%"
 7 | 
 8 | 
 9 | group_privilege:
10 |   - group: "foo"
11 |     domain: "example.com"
12 |     privilege: "full"
13 | 
14 |   - group: "devops"
15 |     domain: "example.com"
16 |     privilege: "full"
17 | 
18 | 
19 | privilege_rule:
20 |   - domain: "example.com"
21 |     privilege: "full"
22 |     path: "%"
23 |     method: "GET"
24 | 
25 |   - domain: "example.com"
26 |     privilege: "full"
27 |     path: "%"
28 |     method: "POST"
29 | 
30 | 


--------------------------------------------------------------------------------
/sproxy.example.yml:
--------------------------------------------------------------------------------
  1 | # NOTE: You can use the !include directive to import parts of this file.
  2 | 
  3 | # Logging level: debug, info, warn, error.
  4 | # Optional. Default is debug.
  5 | #
  6 | # log_level: debug
  7 | 
  8 | # The port Sproxy listens on (HTTPS).
  9 | # Optional. Default is 443.
 10 | #
 11 | # Example:
 12 | # listen: 8443
 13 | #
 14 | # listen:
 15 | 
 16 | # Whether SSL is used on port defined by `listen`.
 17 | # You should only set it to false iff you intent to do SSL-termination
 18 | # somewhere else, e. g. at a load-balancer in a local network.
 19 | # If true, you also have to specify `ssl_key` and `ssl_cert`.
 20 | # Note that there is no way Sproxy can be usable without HTTPS/SSL at the user side,
 21 | # because Sproxy sets cookie for HTTPS only.
 22 | # Optional. Default is true.
 23 | # ssl: true
 24 | 
 25 | # Listen on port 80 and redirect HTTP requests to HTTPS (see `https_port`).
 26 | # Optional. Default is true when `listen` == 443, otherwise false.
 27 | #
 28 | # listen80: true
 29 | 
 30 | # Port used in redirection of HTTP requests to HTTPS.
 31 | # I. e., http://example.com -> https://example.com[:https_port],
 32 | # If `https_port` == 443, the port part if omitted.
 33 | # This is useful when behind a dumb proxy or load-balancer, like Amazon ELB,
 34 | # (and`ssl` == false). It's unlikely that something other than 443
 35 | # is exposed to users, but if you are behind a proxy
 36 | # you can't really know the correct https port.
 37 | # Optional. Default is as `listen`.
 38 | #
 39 | # Example:
 40 | # https_port: 4040
 41 | #
 42 | # https_port:
 43 | 
 44 | # Whether HTTP2 is enabled. Optional. Default is true.
 45 | #
 46 | # http2: true
 47 | 
 48 | # The system user Sproxy switches to if launched as root (after opening the ports).
 49 | # Optional. Default is sproxy.
 50 | #
 51 | # user: sproxy
 52 | 
 53 | # Home directory for various files including SQLite3 authorization database.
 54 | # Optional. Default is current directory.
 55 | #
 56 | # home: "."
 57 | 
 58 | 
 59 | # File with SSL certificate. Required if `ssl` == true.
 60 | # It can be a bundle with the server certificate coming first:
 61 | # cat me-cert.pem CA-cert.pem > cert.pem
 62 | # Once again: most wanted certs go first ;-)
 63 | # Or you can opt in using of `ssl_cert_chain`
 64 | ssl_cert: /path/cert.pem
 65 | 
 66 | # File with SSL key (secret!). Required if `ssl` = true.
 67 | ssl_key: /path/key.pem
 68 | 
 69 | # Chain SSL certificate files.
 70 | # Optional. Default is an empty list
 71 | # Example:
 72 | # ssl_cert_chain:
 73 | #   - /path/foo.pem
 74 | #   - /path/bar.pem
 75 | #
 76 | # ssl_cert_chain: []
 77 | 
 78 | 
 79 | # PostgreSQL database connection string.
 80 | # Optional. If specified, sproxy will periodically pull the data from this
 81 | # database into internal SQLite3 database. Define password in a file
 82 | # referenced by the PGPASSFILE environment variable. Or use the `pgpassfile` option.
 83 | # Cannot be used with the `datafile` option.
 84 | # Example:
 85 | # database: "user=sproxy-readonly dbname=sproxy port=6001"
 86 | #
 87 | # database:
 88 | 
 89 | # PostgreSQL password file.
 90 | # Optional. If specified, sproxy will set PGPASSFILE environment variable pointing to this file
 91 | # Example:
 92 | # pgpassfile: /run/keys/sproxy.pgpass
 93 | #
 94 | # pgpassfile:
 95 | 
 96 | 
 97 | # YAML file used to fill internal SQLite3 database.
 98 | # Optional. If specified, Sproxy will import it on start overwriting
 99 | # and existing data in the internal database.
100 | # Useful for development or some simple deployments.
101 | # Cannot be used with the `database` option.
102 | # For example see the datafile.example.yml
103 | #
104 | # datafile: /path/data.yml
105 | 
106 | 
107 | # Arbitrary string used to sign sproxy cookie and other things (secret!).
108 | # Optional. If not specified, a random key is generated on startup, and
109 | # as a consequence, restaring sproxy will invalidate existing user sessions.
110 | # This option could be useful for load-balancing with multiple sproxy instances,
111 | # when all instances must understand cookies created by each other.
112 | # This should not be very large, a few random bytes are fine.
113 | # 
114 | # key: !include /run/keys/sproxy.secret
115 | 
116 | 
117 | # Credentials for supported OAuth2 providers.
118 | # Currently supported: "google", "linkedin"
119 | # At least one provider is required.
120 | # Attributes:
121 | #   client_id     - OAuth2 client ID.
122 | #   client_secret - OAuth2 client secret.
123 | #
124 | # Examples:
125 | #
126 | # oauth2:
127 | #   google:
128 | #     client_id: "XXXXXXXXXXXX-YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY.apps.googleusercontent.com"
129 | #     client_secret: !include /run/keys/XXXXXXXXXXXX-YYYYYYYYYYYYYYYYYYYYYYYYYYYYYYYY.apps.googleusercontent.com
130 | #
131 | #   linkedin:
132 | #     client_id: "xxxxxxxxxxxxxx"
133 | #     client_secret: !include "/run/keys/xxxxxxxxxxxxxx"
134 | #
135 | #   yandex:
136 | #     client_id: xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
137 | #     client_secret: yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy
138 | #
139 | #
140 | # oauth2:
141 | #   google:
142 | #     client_id:
143 | #     client_secret:
144 | 
145 | 
146 | # Backend servers. At least one is required.
147 | # NOTE: backends at TCP port are not secure, even on localhost,
148 | # because any local user can connect to the backend bypassing sproxy
149 | # authentication and authorization.
150 | #
151 | # It is recommended to communicate with backends via unix sockets only.
152 | # Unix sockets should be secured with proper unix file permissions.
153 | #
154 | # Backend attributes:
155 | #   name      - the domain name as in the Host HTTP header (without optional colon and port).
156 | #               May include wildcards * and ?. The first matching
157 | #               backend will be used. Examples: "*.example.com", "wiki.corp.com".
158 | #               Optional. Default is "*".
159 | #   address   - backend IP address. Optional. Default is 127.0.0.1.
160 | #   port      - backend TCP port. Required unless unix socket is defined.
161 | #   socket    - unix socket. Highly recommended for security reasons.
162 | #               If defined, IP address and TCP port are ignored.
163 | #
164 | #   cookie_name    - sproxy cookie name. Optional. Default is "sproxy".
165 | #   cookie_domain  - sproxy cookie domain. Optional. Default is the request host name as per RFC2109.
166 | #   cookie_max_age - sproxy cookie shelflife in seconds. Optional. Default is 604800 (7 days).
167 | #   conn_count     - number of connections to keep alive. Optional. Default is 32.
168 | #                    This is specific to Haskell HTTP Client library, and is per host name,
169 | #                    not per backend. HTTP Client's default is 10.
170 | #
171 | # backends:
172 | #   - name: wiki.example.com
173 | #     port: 9090
174 | #     cookie_name: sproxy_example
175 | #     cookie_max_age: 86400
176 | #
177 | backends:
178 |   - port: 8080
179 | 
180 | 


--------------------------------------------------------------------------------
/sproxy.sql:
--------------------------------------------------------------------------------
  1 | /*
  2 | 
  3 | -- as super user:
  4 | 
  5 | -- NOT idempotent
  6 | CREATE DATABASE sproxy;
  7 | CREATE ROLE sproxy;            -- this is for management tools like sproxy-web
  8 | CREATE ROLE "sproxy-readonly"; -- this is for sproxy itself (sic!)
  9 | 
 10 | -- idempotent from here on:
 11 | ALTER DATABASE sproxy OWNER TO sproxy;
 12 | ALTER ROLE "sproxy-readonly" LOGIN;
 13 | ALTER ROLE sproxy LOGIN;
 14 | 
 15 | \c sproxy;
 16 | 
 17 | SET ROLE sproxy;
 18 | -- as database owner (sproxy) from here on:
 19 | 
 20 | GRANT SELECT ON ALL TABLES IN SCHEMA public TO "sproxy-readonly";
 21 | ALTER DEFAULT PRIVILEGES IN SCHEMA public GRANT SELECT ON TABLES TO "sproxy-readonly";
 22 | 
 23 | */
 24 | 
 25 | 
 26 | BEGIN;
 27 | 
 28 | CREATE TABLE IF NOT EXISTS "group" (
 29 |   "group" TEXT NOT NULL PRIMARY KEY,
 30 |   "comment" TEXT
 31 | );
 32 | 
 33 | CREATE TABLE IF NOT EXISTS "user" (
 34 |   "email" TEXT NOT NULL PRIMARY KEY,
 35 |   "comment" TEXT
 36 | );
 37 | 
 38 | -- | group        |
 39 | -- |--------------|
 40 | -- | data science |
 41 | -- | devops       |
 42 | -- | all          |
 43 | -- | regional     |
 44 | 
 45 | 
 46 | CREATE TABLE IF NOT EXISTS group_member (
 47 |   "group" TEXT REFERENCES "group" ("group") ON UPDATE CASCADE ON DELETE CASCADE NOT NULL,
 48 |   "email" TEXT REFERENCES "user" ("email") ON UPDATE CASCADE ON DELETE CASCADE NOT NULL,
 49 |   "comment" TEXT,
 50 |   PRIMARY KEY ("group", email)
 51 | );
 52 | 
 53 | -- | group        | email                  |
 54 | -- |--------------+------------------------|
 55 | -- | data science | blah@example.com       |
 56 | -- | data science | foo@example.com        |
 57 | -- | devops       | devops1@example.com    |
 58 | -- | devops       | devops2@example.com    |
 59 | -- | all          | %@example.com          |
 60 | 
 61 | -- Find out which groups a user (email address) belongs to:
 62 | -- SELECT "group" FROM group_member WHERE 'email.address' LIKE email
 63 | 
 64 | CREATE TABLE IF NOT EXISTS domain (
 65 |   domain TEXT NOT NULL PRIMARY KEY,
 66 |   "comment" TEXT
 67 | );
 68 | 
 69 | -- | domain                |
 70 | -- |-----------------------|
 71 | -- | app1.example.com      |
 72 | -- | app2.example.com      |
 73 | -- | app3.example.com      |
 74 | 
 75 | CREATE TABLE IF NOT EXISTS privilege (
 76 |   "domain" TEXT REFERENCES domain (domain) ON UPDATE CASCADE ON DELETE CASCADE NOT NULL,
 77 |   privilege TEXT NOT NULL,
 78 |   "comment" TEXT,
 79 |   PRIMARY KEY ("domain", privilege)
 80 | );
 81 | 
 82 | -- | domain                | privilege  |
 83 | -- |-----------------------+------------|
 84 | -- | app3.example.com      | view       |
 85 | -- | app3.example.com      | export     |
 86 | -- | app1.example.com      | list users |
 87 | -- | app1.example.com      | add users  |
 88 | 
 89 | CREATE TABLE IF NOT EXISTS privilege_rule (
 90 |   "domain" TEXT NOT NULL,
 91 |   privilege TEXT NOT NULL,
 92 |   "path" TEXT NOT NULL,
 93 |   "method" TEXT NOT NULL,
 94 |   "comment" TEXT,
 95 |   FOREIGN KEY ("domain", privilege) REFERENCES privilege ("domain", privilege) ON UPDATE CASCADE ON DELETE CASCADE,
 96 |   PRIMARY KEY ("domain", "path", "method")
 97 | );
 98 | 
 99 | -- | domain                | privilege  | path      | method |
100 | -- |-----------------------+------------+-----------+--------|
101 | -- | app3.example.com      | view       | /%        | %      |
102 | -- | app3.example.com      | export     | /export/% | %      |
103 | -- | app1.example.com      | list users | /users    | GET    |
104 | -- | app1.example.com      | list users | /user/%   | GET    |
105 | -- | app1.example.com      | add users  | /users    | POST   |
106 | 
107 | CREATE TABLE IF NOT EXISTS group_privilege (
108 |   "group" TEXT REFERENCES "group" ("group") ON UPDATE CASCADE ON DELETE CASCADE NOT NULL,
109 |   "domain" TEXT NOT NULL,
110 |   privilege TEXT NOT NULL,
111 |   "comment" TEXT,
112 |   FOREIGN KEY ("domain", privilege) REFERENCES privilege ("domain", privilege) ON UPDATE CASCADE ON DELETE CASCADE,
113 |   PRIMARY KEY ("group", "domain", privilege)
114 | );
115 | 
116 | -- | group        | domain                | privilege  |
117 | -- |--------------+-----------------------+------------|
118 | -- | data science | app3.example.com      | view       |
119 | -- | data science | app3.example.com      | export     |
120 | -- | all          | app1.example.com      | list users |
121 | -- | devops       | app1.example.com      | add users  |
122 | 
123 | -- Check if the user is authorized for the request. Let's break it
124 | -- down for understanding:
125 | 
126 | -- The privilege required to access a URL is the most specific
127 | -- (longest) match. To determine length, we look at the number of
128 | -- slashes in the URL pattern (number of path components).
129 | --
130 | -- SELECT p.privilege FROM privilege p
131 | -- INNER JOIN privilege_rule pr ON pr."domain" = p."domain" AND pr.privilege = p.privilege
132 | -- WHERE 'app3.example.com' LIKE pr."domain" AND '/export/test' LIKE "path" AND 'GET' ILIKE "method"
133 | -- ORDER by array_length(regexp_split_to_array("path", '/'), 1) DESC LIMIT 1
134 | --
135 | -- To get the groups that grant the user access, put that in a subquery:
136 | --
137 | -- SELECT gp."group" FROM group_privilege gp
138 | -- INNER JOIN group_member gm ON gm."group" = gp."group"
139 | -- WHERE 'blah@example.com' LIKE email
140 | -- AND 'app3.example.com' LIKE "domain"
141 | -- AND privilege IN (
142 | --   SELECT p.privilege FROM privilege p
143 | --   INNER JOIN privilege_rule pr ON pr."domain" = p."domain" AND pr.privilege = p.privilege
144 | --   WHERE 'app3.example.com' LIKE pr."domain" AND '/export/test' LIKE "path" AND 'GET' ILIKE "method"
145 | --   ORDER by array_length(regexp_split_to_array("path", '/'), 1) DESC LIMIT 1
146 | -- )
147 | --
148 | -- If you just want to know if a user has access or not, you can
149 | -- change the first line to:
150 | --
151 | -- SELECT COUNT(*) > 0 FROM group_privilege gp
152 | --
153 | -- Note for the future: If you want to support wildcards that match
154 | -- only a single path component (e.g. app1.example.com/user/:/email),
155 | -- you could try something like:
156 | --
157 | -- WHERE 'url' ~ regexp_replace(url, ':', '[^/]+')
158 | --
159 | -- But you'd also have to escape any regexp special characters in the
160 | -- url as well (i.e. dots).
161 | 
162 | -- Example data for development:
163 | /*
164 |   INSERT INTO domain (domain) VALUES ('example.com');
165 |   INSERT INTO "group" ("group") VALUES ('dev');
166 |   INSERT INTO group_member ("group", email) VALUES ('dev', '%');
167 |   INSERT INTO privilege (domain, privilege) VALUES ('example.com', 'full');
168 |   INSERT INTO group_privilege ("group", domain, privilege) VALUES ('dev', 'example.com', 'full');
169 |   INSERT INTO privilege_rule (domain, privilege, path, method) VALUES ('example.com', 'full', '%', 'GET');
170 |   INSERT INTO privilege_rule (domain, privilege, path, method) VALUES ('example.com', 'full', '%', 'HEAD');
171 |   INSERT INTO privilege_rule (domain, privilege, path, method) VALUES ('example.com', 'full', '%', 'POST');
172 |   INSERT INTO privilege_rule (domain, privilege, path, method) VALUES ('example.com', 'full', '%', 'PUT');
173 | */
174 | 
175 | END;
176 | 
177 | 


--------------------------------------------------------------------------------
/sproxy2.cabal:
--------------------------------------------------------------------------------
 1 | name: sproxy2
 2 | version: 1.96.0
 3 | synopsis: Secure HTTP proxy for authenticating users via OAuth2
 4 | description:
 5 |   Sproxy is secure by default. No requests makes it to the backend
 6 |   server if they haven't been explicitly whitelisted.  Sproxy is
 7 |   independent. Any web application written in any language can
 8 |   use it.
 9 | license: MIT
10 | license-file: LICENSE
11 | author: Igor Pashev <pashev.igor@gmail.com>
12 | maintainer: Igor Pashev <pashev.igor@gmail.com>
13 | copyright:
14 |   2016-2017, Zalora South East Asia Pte. Ltd;
15 |   2017, Igor Pashev <pashev.igor@gmail.com>
16 | category: Databases, Web
17 | build-type: Simple
18 | cabal-version: >= 1.20
19 | extra-source-files:
20 |   ChangeLog.md
21 |   README.md
22 |   datafile.example.yml
23 |   sproxy.example.yml
24 |   sproxy.sql
25 | 
26 | source-repository head
27 |   type: git
28 |   location: https://github.com/ip1981/sproxy2.git
29 | 
30 | executable sproxy2
31 |     default-language: Haskell2010
32 |     ghc-options: -Wall -static -threaded
33 |     hs-source-dirs: src
34 |     main-is: Main.hs
35 |     other-modules:
36 |       Sproxy.Application
37 |       Sproxy.Application.Access
38 |       Sproxy.Application.Cookie
39 |       Sproxy.Application.OAuth2
40 |       Sproxy.Application.OAuth2.Common
41 |       Sproxy.Application.OAuth2.Google
42 |       Sproxy.Application.OAuth2.LinkedIn
43 |       Sproxy.Application.OAuth2.Yandex
44 |       Sproxy.Application.State
45 |       Sproxy.Config
46 |       Sproxy.Logging
47 |       Sproxy.Server
48 |       Sproxy.Server.DB
49 |       Sproxy.Server.DB.DataFile
50 |     build-depends:
51 |         base >= 4.8 && < 50
52 |       , aeson
53 |       , base64-bytestring
54 |       , blaze-builder
55 |       , bytestring
56 |       , cereal
57 |       , conduit
58 |       , containers
59 |       , cookie >= 0.4.2
60 |       , docopt
61 |       , entropy
62 |       , Glob
63 |       , http-client >= 0.5.3
64 |       , http-conduit
65 |       , http-types
66 |       , interpolatedstring-perl6
67 |       , network
68 |       , postgresql-simple
69 |       , resource-pool
70 |       , SHA
71 |       , sqlite-simple
72 |       , text
73 |       , time
74 |       , unix
75 |       , unordered-containers
76 |       , wai
77 |       , wai-conduit
78 |       , warp
79 |       , warp-tls >= 3.2
80 |       , word8
81 |       , yaml >= 0.8.4
82 | 
83 | 


--------------------------------------------------------------------------------
/src/Main.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE QuasiQuotes #-}
 2 | 
 3 | module Main
 4 |   ( main
 5 |   ) where
 6 | 
 7 | import Data.Maybe (fromJust)
 8 | import Data.Version (showVersion)
 9 | import Paths_sproxy2 (version) -- from cabal
10 | import qualified System.Console.Docopt.NoTH as O
11 | import System.Environment (getArgs)
12 | import Text.InterpolatedString.Perl6 (qc)
13 | 
14 | import Sproxy.Server (server)
15 | 
16 | usage :: String
17 | usage =
18 |   "sproxy2 " ++
19 |   showVersion version ++
20 |   " - HTTP proxy for authenticating users via OAuth2" ++
21 |   [qc|
22 | 
23 | Usage:
24 |   sproxy2 [options]
25 | 
26 | Options:
27 |   -c, --config=FILE        Configuration file [default: sproxy.yml]
28 |   -h, --help               Show this message
29 | 
30 | |]
31 | 
32 | main :: IO ()
33 | main = do
34 |   doco <- O.parseUsageOrExit usage
35 |   args <- O.parseArgsOrExit doco =<< getArgs
36 |   if args `O.isPresent` O.longOption "help"
37 |     then putStrLn $ O.usage doco
38 |     else do
39 |       let configFile = fromJust . O.getArg args $ O.longOption "config"
40 |       server configFile
41 | 


--------------------------------------------------------------------------------
/src/Sproxy/Application.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE LambdaCase #-}
  2 | {-# LANGUAGE OverloadedStrings #-}
  3 | {-# LANGUAGE QuasiQuotes #-}
  4 | 
  5 | module Sproxy.Application
  6 |   ( sproxy
  7 |   , redirect
  8 |   ) where
  9 | 
 10 | import Blaze.ByteString.Builder (toByteString)
 11 | import Blaze.ByteString.Builder.ByteString (fromByteString)
 12 | import Control.Exception
 13 |        (Exception, Handler(..), SomeException, catches, displayException)
 14 | import qualified Data.Aeson as JSON
 15 | import Data.ByteString (ByteString)
 16 | import Data.ByteString as BS (break, intercalate)
 17 | import Data.ByteString.Char8 (pack, unpack)
 18 | import Data.ByteString.Lazy (fromStrict)
 19 | import Data.Conduit (Flush(Chunk), mapOutput)
 20 | import Data.HashMap.Strict as HM (HashMap, foldrWithKey, lookup)
 21 | import Data.List (find, partition)
 22 | import Data.Map as Map
 23 |        (delete, fromListWith, insert, insertWith, toList)
 24 | import Data.Maybe (fromJust, fromMaybe)
 25 | import Data.Monoid ((<>))
 26 | import Data.Text (Text)
 27 | import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 28 | import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 29 | import Data.Word (Word16)
 30 | import Data.Word8 (_colon)
 31 | import Foreign.C.Types (CTime(..))
 32 | import qualified Network.HTTP.Client as BE
 33 | import Network.HTTP.Client.Conduit (bodyReaderSource)
 34 | import Network.HTTP.Conduit
 35 |        (requestBodySourceChunkedIO, requestBodySourceIO)
 36 | import Network.HTTP.Types
 37 |        (RequestHeaders, ResponseHeaders, methodGet, methodPost)
 38 | import Network.HTTP.Types.Header
 39 |        (hConnection, hContentLength, hContentType, hCookie, hLocation,
 40 |         hTransferEncoding)
 41 | import Network.HTTP.Types.Status
 42 |        (Status(..), badGateway502, badRequest400, forbidden403, found302,
 43 |         internalServerError500, methodNotAllowed405, movedPermanently301,
 44 |         networkAuthenticationRequired511, notFound404, ok200, seeOther303,
 45 |         temporaryRedirect307)
 46 | import Network.Socket (NameInfoFlag(NI_NUMERICHOST), getNameInfo)
 47 | import qualified Network.Wai as W
 48 | import Network.Wai.Conduit (responseSource, sourceRequestBody)
 49 | import System.FilePath.Glob (Pattern, match)
 50 | import System.Posix.Time (epochTime)
 51 | import Text.InterpolatedString.Perl6 (qc)
 52 | import Web.Cookie (Cookies, parseCookies, renderCookies)
 53 | import qualified Web.Cookie as WC
 54 | 
 55 | import Sproxy.Application.Cookie
 56 |        (AuthCookie(..), AuthUser, cookieDecode, cookieEncode, getEmail,
 57 |         getEmailUtf8, getFamilyNameUtf8, getGivenNameUtf8)
 58 | import Sproxy.Application.OAuth2.Common (OAuth2Client(..))
 59 | import qualified Sproxy.Application.State as State
 60 | import Sproxy.Config (BackendConf(..))
 61 | import qualified Sproxy.Logging as Log
 62 | import Sproxy.Server.DB
 63 |        (Database, userAccess, userExists, userGroups)
 64 | 
 65 | redirect :: Word16 -> W.Application
 66 | redirect p req resp =
 67 |   case requestDomain req of
 68 |     Nothing -> badRequest "missing host" req resp
 69 |     Just domain -> do
 70 |       Log.info $ "redirecting to " ++ show location ++ ": " ++ showReq req
 71 |       resp $ W.responseBuilder status [(hLocation, location)] mempty
 72 |       where status =
 73 |               if W.requestMethod req == methodGet
 74 |                 then movedPermanently301
 75 |                 else temporaryRedirect307
 76 |             newhost =
 77 |               if p == 443
 78 |                 then domain
 79 |                 else domain <> ":" <> pack (show p)
 80 |             location =
 81 |               "https://" <> newhost <> W.rawPathInfo req <> W.rawQueryString req
 82 | 
 83 | sproxy ::
 84 |      ByteString
 85 |   -> Database
 86 |   -> HashMap Text OAuth2Client
 87 |   -> [(Pattern, BackendConf, BE.Manager)]
 88 |   -> W.Application
 89 | sproxy key db oa2 backends =
 90 |   logException $ \req resp -> do
 91 |     Log.debug $ "sproxy <<< " ++ showReq req
 92 |     case requestDomain req of
 93 |       Nothing -> badRequest "missing host" req resp
 94 |       Just domain ->
 95 |         case find (\(p, _, _) -> match p (unpack domain)) backends of
 96 |           Nothing -> notFound "backend" req resp
 97 |           Just (_, be, mgr) -> do
 98 |             let cookieName = pack $ beCookieName be
 99 |                 cookieDomain = pack <$> beCookieDomain be
100 |             case W.pathInfo req of
101 |               ["robots.txt"] -> get robots req resp
102 |               (".sproxy":proxy) ->
103 |                 case proxy of
104 |                   ["logout"] ->
105 |                     get (logout key cookieName cookieDomain) req resp
106 |                   ["oauth2", provider] ->
107 |                     case HM.lookup provider oa2 of
108 |                       Nothing -> notFound "OAuth2 provider" req resp
109 |                       Just oa2c ->
110 |                         get (oauth2callback key db (provider, oa2c) be) req resp
111 |                   ["access"] -> do
112 |                     now <- Just <$> epochTime
113 |                     case extractCookie key now cookieName req of
114 |                       Nothing -> authenticationRequired key oa2 req resp
115 |                       Just (authCookie, _) ->
116 |                         post (checkAccess db authCookie) req resp
117 |                   _ -> notFound "proxy" req resp
118 |               _ -> do
119 |                 now <- Just <$> epochTime
120 |                 case extractCookie key now cookieName req of
121 |                   Nothing -> authenticationRequired key oa2 req resp
122 |                   Just cs@(authCookie, _) ->
123 |                     authorize db cs req >>= \case
124 |                       Nothing -> forbidden authCookie req resp
125 |                       Just req' -> forward mgr req' resp
126 | 
127 | robots :: W.Application
128 | robots _ resp =
129 |   resp $
130 |   W.responseLBS
131 |     ok200
132 |     [(hContentType, "text/plain; charset=utf-8")]
133 |     "User-agent: *\nDisallow: /"
134 | 
135 | oauth2callback ::
136 |      ByteString
137 |   -> Database
138 |   -> (Text, OAuth2Client)
139 |   -> BackendConf
140 |   -> W.Application
141 | oauth2callback key db (provider, oa2c) be req resp =
142 |   case param "code" of
143 |     Nothing -> badRequest "missing auth code" req resp
144 |     Just code ->
145 |       case param "state" of
146 |         Nothing -> badRequest "missing auth state" req resp
147 |         Just state ->
148 |           case State.decode key state of
149 |             Left msg -> badRequest ("invalid state: " ++ msg) req resp
150 |             Right url -> do
151 |               au <- oauth2Authenticate oa2c code (redirectURL req provider)
152 |               let email = getEmail au
153 |               Log.info $ "login " ++ show email ++ " by " ++ show provider
154 |               exists <- userExists db email
155 |               if exists
156 |                 then authenticate key be au url req resp
157 |                 else userNotFound au req resp
158 |   where
159 |     param p = do
160 |       (_, v) <- find ((==) p . fst) $ W.queryString req
161 |       v
162 | 
163 | -- XXX: RFC6265: the user agent MUST NOT attach more than one Cookie header field
164 | extractCookie ::
165 |      ByteString
166 |   -> Maybe CTime
167 |   -> ByteString
168 |   -> W.Request
169 |   -> Maybe (AuthCookie, Cookies)
170 | extractCookie key now name req = do
171 |   (_, cookies) <- find ((==) hCookie . fst) $ W.requestHeaders req
172 |   (auth, others) <- discriminate cookies
173 |   case cookieDecode key auth of
174 |     Left _ -> Nothing
175 |     Right cookie ->
176 |       if maybe True (acExpiry cookie >) now
177 |         then Just (cookie, others)
178 |         else Nothing
179 |   where
180 |     discriminate cs =
181 |       case partition ((==) name . fst) $ parseCookies cs of
182 |         ((_, x):_, xs) -> Just (x, xs)
183 |         _ -> Nothing
184 | 
185 | authenticate ::
186 |      ByteString -> BackendConf -> AuthUser -> ByteString -> W.Application
187 | authenticate key be user url _req resp = do
188 |   now <- epochTime
189 |   let domain = pack <$> beCookieDomain be
190 |       expiry = now + CTime (beCookieMaxAge be)
191 |       authCookie = AuthCookie {acUser = user, acExpiry = expiry}
192 |       cookie =
193 |         WC.def
194 |         { WC.setCookieName = pack $ beCookieName be
195 |         , WC.setCookieHttpOnly = True
196 |         , WC.setCookiePath = Just "/"
197 |         , WC.setCookieSameSite = Nothing
198 |         , WC.setCookieSecure = True
199 |         , WC.setCookieValue = cookieEncode key authCookie
200 |         , WC.setCookieDomain = domain
201 |         , WC.setCookieExpires =
202 |             Just . posixSecondsToUTCTime . realToFrac $ expiry
203 |         }
204 |   resp $
205 |     W.responseLBS
206 |       seeOther303
207 |       [ (hLocation, url)
208 |       , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie)
209 |       ]
210 |       ""
211 | 
212 | authorize ::
213 |      Database -> (AuthCookie, Cookies) -> W.Request -> IO (Maybe W.Request)
214 | authorize db (authCookie, otherCookies) req = do
215 |   let user = acUser authCookie
216 |       domain = decodeUtf8 . fromJust $ requestDomain req
217 |       email = getEmail user
218 |       emailUtf8 = getEmailUtf8 user
219 |       familyUtf8 = getFamilyNameUtf8 user
220 |       givenUtf8 = getGivenNameUtf8 user
221 |       method = decodeUtf8 $ W.requestMethod req
222 |       path = decodeUtf8 $ W.rawPathInfo req
223 |   grps <- userGroups db email domain path method
224 |   if null grps
225 |     then return Nothing
226 |     else do
227 |       ip <-
228 |         pack . fromJust . fst <$>
229 |         getNameInfo [NI_NUMERICHOST] True False (W.remoteHost req)
230 |       return . Just $
231 |         req
232 |         { W.requestHeaders =
233 |             toList $
234 |             insert "From" emailUtf8 $
235 |             insert "X-Groups" (BS.intercalate "," $ encodeUtf8 <$> grps) $
236 |             insert "X-Given-Name" givenUtf8 $
237 |             insert "X-Family-Name" familyUtf8 $
238 |             insert "X-Forwarded-Proto" "https" $
239 |             insertWith (flip combine) "X-Forwarded-For" ip $
240 |             setCookies otherCookies $
241 |             fromListWith combine $ W.requestHeaders req
242 |         }
243 |   where
244 |     combine a b = a <> "," <> b
245 |     setCookies [] = delete hCookie
246 |     setCookies cs = insert hCookie (toByteString . renderCookies $ cs)
247 | 
248 | checkAccess :: Database -> AuthCookie -> W.Application
249 | checkAccess db authCookie req resp = do
250 |   let email = getEmail . acUser $ authCookie
251 |       domain = decodeUtf8 . fromJust $ requestDomain req
252 |   body <- W.strictRequestBody req
253 |   case JSON.eitherDecode' body of
254 |     Left err -> badRequest err req resp
255 |     Right inq -> do
256 |       Log.debug $ "access <<< " ++ show inq
257 |       tags <- userAccess db email domain inq
258 |       Log.debug $ "access >>> " ++ show tags
259 |       resp $
260 |         W.responseLBS
261 |           ok200
262 |           [(hContentType, "application/json")]
263 |           (JSON.encode tags)
264 | 
265 | -- XXX If something seems strange, think about HTTP/1.1 <-> HTTP/1.0.
266 | -- FIXME For HTTP/1.0 backends we might need an option
267 | -- FIXME in config file. HTTP Client does HTTP/1.1 by default.
268 | forward :: BE.Manager -> W.Application
269 | forward mgr req resp = do
270 |   let beReq =
271 |         BE.defaultRequest
272 |         { BE.method = W.requestMethod req
273 |         , BE.path = W.rawPathInfo req
274 |         , BE.queryString = W.rawQueryString req
275 |         , BE.requestHeaders = modifyRequestHeaders $ W.requestHeaders req
276 |         , BE.redirectCount = 0
277 |         , BE.decompress = const False
278 |         , BE.requestBody =
279 |             case W.requestBodyLength req of
280 |               W.ChunkedBody ->
281 |                 requestBodySourceChunkedIO (sourceRequestBody req)
282 |               W.KnownLength l ->
283 |                 requestBodySourceIO (fromIntegral l) (sourceRequestBody req)
284 |         }
285 |       msg =
286 |         unpack (BE.method beReq <> " " <> BE.path beReq <> BE.queryString beReq)
287 |   Log.debug $ "BACKEND <<< " ++ msg ++ " " ++ show (BE.requestHeaders beReq)
288 |   BE.withResponse beReq mgr $ \res -> do
289 |     let status = BE.responseStatus res
290 |         headers = BE.responseHeaders res
291 |         body =
292 |           mapOutput (Chunk . fromByteString) . bodyReaderSource $
293 |           BE.responseBody res
294 |         logging =
295 |           if statusCode status `elem` [400, 500]
296 |             then Log.warn
297 |             else Log.debug
298 |     logging $
299 |       "BACKEND >>> " ++
300 |       show (statusCode status) ++ " on " ++ msg ++ " " ++ show headers ++ "\n"
301 |     resp $ responseSource status (modifyResponseHeaders headers) body
302 | 
303 | modifyRequestHeaders :: RequestHeaders -> RequestHeaders
304 | modifyRequestHeaders = filter (\(n, _) -> n `notElem` ban)
305 |   where
306 |     ban =
307 |       [ hConnection
308 |       , hContentLength -- XXX This is set automtically before sending request to backend
309 |       , hTransferEncoding -- XXX Likewise
310 |       ]
311 | 
312 | modifyResponseHeaders :: ResponseHeaders -> ResponseHeaders
313 | modifyResponseHeaders = filter (\(n, _) -> n `notElem` ban)
314 |   where
315 |     ban =
316 |       [ hConnection
317 |       -- XXX WAI docs say we MUST NOT add (keep) Content-Length, Content-Range, and Transfer-Encoding,
318 |       -- XXX but we use streaming body, which may add Transfer-Encoding only.
319 |       -- XXX Thus we keep Content-* headers.
320 |       , hTransferEncoding
321 |       ]
322 | 
323 | authenticationRequired ::
324 |      ByteString -> HashMap Text OAuth2Client -> W.Application
325 | authenticationRequired key oa2 req resp = do
326 |   Log.info $ "511 Unauthenticated: " ++ showReq req
327 |   resp $
328 |     W.responseLBS
329 |       networkAuthenticationRequired511
330 |       [(hContentType, "text/html; charset=utf-8")]
331 |       page
332 |   where
333 |     path =
334 |       if W.requestMethod req == methodGet
335 |         then W.rawPathInfo req <> W.rawQueryString req
336 |         else "/"
337 |     state =
338 |       State.encode key $
339 |       "https://" <> fromJust (W.requestHeaderHost req) <> path
340 |     authLink :: Text -> OAuth2Client -> ByteString -> ByteString
341 |     authLink provider oa2c html =
342 |       let u = oauth2AuthorizeURL oa2c state (redirectURL req provider)
343 |           d = pack $ oauth2Description oa2c
344 |       in [qc|{html}<p><a href="{u}">Authenticate with {d}</a></p>|]
345 |     authHtml = foldrWithKey authLink "" oa2
346 |     page =
347 |       fromStrict
348 |         [qc|
349 | <!DOCTYPE html>
350 | <html lang="en">
351 |   <head>
352 |     <meta charset="utf-8">
353 |     <title>Authentication required</title>
354 |   </head>
355 |   <body style="text-align:center;">
356 |   <h1>Authentication required</h1>
357 |   {authHtml}
358 |   </body>
359 | </html>
360 | |]
361 | 
362 | forbidden :: AuthCookie -> W.Application
363 | forbidden ac req resp = do
364 |   Log.info $ "403 Forbidden: " ++ show email ++ ": " ++ showReq req
365 |   resp $
366 |     W.responseLBS forbidden403 [(hContentType, "text/html; charset=utf-8")] page
367 |   where
368 |     email = getEmailUtf8 . acUser $ ac
369 |     page =
370 |       fromStrict
371 |         [qc|
372 | <!DOCTYPE html>
373 | <html lang="en">
374 |   <head>
375 |     <meta charset="utf-8">
376 |     <title>Access Denied</title>
377 |   </head>
378 |   <body>
379 |   <h1>Access Denied</h1>
380 |     <p>You are currently logged in as <strong>{email}</strong></p>
381 |     <p><a href="/.sproxy/logout">Logout</a></p>
382 |   </body>
383 | </html>
384 | |]
385 | 
386 | userNotFound :: AuthUser -> W.Application
387 | userNotFound au _ resp = do
388 |   Log.info $ "404 User not found: " ++ show email
389 |   resp $
390 |     W.responseLBS notFound404 [(hContentType, "text/html; charset=utf-8")] page
391 |   where
392 |     email = getEmailUtf8 au
393 |     page =
394 |       fromStrict
395 |         [qc|
396 | <!DOCTYPE html>
397 | <html lang="en">
398 |   <head>
399 |     <meta charset="utf-8">
400 |     <title>Access Denied</title>
401 |   </head>
402 |   <body>
403 |   <h1>Access Denied</h1>
404 |     <p>You are not allowed to login as <strong>{email}</strong></p>
405 |     <p><a href="/">Main page</a></p>
406 |   </body>
407 | </html>
408 | |]
409 | 
410 | logout :: ByteString -> ByteString -> Maybe ByteString -> W.Application
411 | logout key cookieName cookieDomain req resp = do
412 |   let host = fromJust $ W.requestHeaderHost req
413 |   case extractCookie key Nothing cookieName req of
414 |     Nothing ->
415 |       resp $ W.responseLBS found302 [(hLocation, "https://" <> host)] ""
416 |     Just _ -> do
417 |       let cookie =
418 |             WC.def
419 |             { WC.setCookieName = cookieName
420 |             , WC.setCookieHttpOnly = True
421 |             , WC.setCookiePath = Just "/"
422 |             , WC.setCookieSameSite = Just WC.sameSiteStrict
423 |             , WC.setCookieSecure = True
424 |             , WC.setCookieValue = "goodbye"
425 |             , WC.setCookieDomain = cookieDomain
426 |             , WC.setCookieExpires =
427 |                 Just . posixSecondsToUTCTime . realToFrac $ CTime 0
428 |             }
429 |       resp $
430 |         W.responseLBS
431 |           found302
432 |           [ (hLocation, "https://" <> host)
433 |           , ("Set-Cookie", toByteString $ WC.renderSetCookie cookie)
434 |           ]
435 |           ""
436 | 
437 | badRequest :: String -> W.Application
438 | badRequest msg req resp = do
439 |   Log.warn $ "400 Bad Request (" ++ msg ++ "): " ++ showReq req
440 |   resp $ W.responseLBS badRequest400 [] "Bad Request"
441 | 
442 | notFound :: String -> W.Application
443 | notFound msg req resp = do
444 |   Log.warn $ "404 Not Found (" ++ msg ++ "): " ++ showReq req
445 |   resp $ W.responseLBS notFound404 [] "Not Found"
446 | 
447 | logException :: W.Middleware
448 | logException app req resp =
449 |   catches (app req resp) [Handler badGateway, Handler internalError]
450 |   where
451 |     internalError :: SomeException -> IO W.ResponseReceived
452 |     internalError = response internalServerError500
453 |     badGateway :: BE.HttpException -> IO W.ResponseReceived
454 |     badGateway = response badGateway502
455 |     response :: Exception e => Status -> e -> IO W.ResponseReceived
456 |     response st e = do
457 |       Log.error $
458 |         show (statusCode st) ++
459 |         " " ++
460 |         unpack (statusMessage st) ++
461 |         ": " ++ displayException e ++ " on " ++ showReq req
462 |       resp $
463 |         W.responseLBS
464 |           st
465 |           [(hContentType, "text/plain")]
466 |           (fromStrict $ statusMessage st)
467 | 
468 | get :: W.Middleware
469 | get app req resp
470 |   | W.requestMethod req == methodGet = app req resp
471 |   | otherwise = do
472 |     Log.warn $ "405 Method Not Allowed: " ++ showReq req
473 |     resp $
474 |       W.responseLBS methodNotAllowed405 [("Allow", "GET")] "Method Not Allowed"
475 | 
476 | post :: W.Middleware
477 | post app req resp
478 |   | W.requestMethod req == methodPost = app req resp
479 |   | otherwise = do
480 |     Log.warn $ "405 Method Not Allowed: " ++ showReq req
481 |     resp $
482 |       W.responseLBS methodNotAllowed405 [("Allow", "POST")] "Method Not Allowed"
483 | 
484 | redirectURL :: W.Request -> Text -> ByteString
485 | redirectURL req provider =
486 |   "https://" <> fromJust (W.requestHeaderHost req) <> "/.sproxy/oauth2/" <>
487 |   encodeUtf8 provider
488 | 
489 | requestDomain :: W.Request -> Maybe ByteString
490 | requestDomain req = do
491 |   h <- W.requestHeaderHost req
492 |   return . fst . BS.break (== _colon) $ h
493 | 
494 | -- XXX: make sure not to reveal the cookie, which can be valid (!)
495 | showReq :: W.Request -> String
496 | showReq req =
497 |   unpack
498 |     (W.requestMethod req <> " " <>
499 |      fromMaybe "<no host>" (W.requestHeaderHost req) <>
500 |      W.rawPathInfo req <>
501 |      W.rawQueryString req <>
502 |      " ") ++
503 |   show (W.httpVersion req) ++
504 |   " " ++
505 |   show (fromMaybe "-" $ W.requestHeaderReferer req) ++
506 |   " " ++
507 |   show (fromMaybe "-" $ W.requestHeaderUserAgent req) ++
508 |   " from " ++ show (W.remoteHost req)
509 | 


--------------------------------------------------------------------------------
/src/Sproxy/Application/Access.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DeriveGeneric #-}
 2 | {-# LANGUAGE OverloadedStrings #-}
 3 | 
 4 | module Sproxy.Application.Access
 5 |   ( Inquiry
 6 |   , Question(..)
 7 |   ) where
 8 | 
 9 | import Data.Aeson (FromJSON)
10 | import Data.HashMap.Strict (HashMap)
11 | import Data.Text (Text)
12 | import GHC.Generics (Generic)
13 | 
14 | data Question = Question
15 |   { path :: Text
16 |   , method :: Text
17 |   } deriving (Generic, Show)
18 | 
19 | instance FromJSON Question
20 | 
21 | type Inquiry = HashMap Text Question
22 | 


--------------------------------------------------------------------------------
/src/Sproxy/Application/Cookie.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | 
 3 | module Sproxy.Application.Cookie
 4 |   ( AuthCookie(..)
 5 |   , AuthUser
 6 |   , cookieDecode
 7 |   , cookieEncode
 8 |   , getEmail
 9 |   , getEmailUtf8
10 |   , getFamilyNameUtf8
11 |   , getGivenNameUtf8
12 |   , newUser
13 |   , setFamilyName
14 |   , setGivenName
15 |   ) where
16 | 
17 | import Data.ByteString (ByteString)
18 | import qualified Data.Serialize as DS
19 | import Data.Text (Text, strip, toLower)
20 | import Data.Text.Encoding (decodeUtf8, encodeUtf8)
21 | import Foreign.C.Types (CTime(..))
22 | 
23 | import qualified Sproxy.Application.State as State
24 | 
25 | data AuthUser = AuthUser
26 |   { auEmail :: ByteString
27 |   , auGivenName :: ByteString
28 |   , auFamilyName :: ByteString
29 |   }
30 | 
31 | data AuthCookie = AuthCookie
32 |   { acUser :: AuthUser
33 |   , acExpiry :: CTime
34 |   }
35 | 
36 | instance DS.Serialize AuthCookie where
37 |   put c = DS.put (auEmail u, auGivenName u, auFamilyName u, x)
38 |     where
39 |       u = acUser c
40 |       x = (\(CTime i) -> i) $ acExpiry c
41 |   get = do
42 |     (e, n, f, x) <- DS.get
43 |     return
44 |       AuthCookie
45 |       { acUser = AuthUser {auEmail = e, auGivenName = n, auFamilyName = f}
46 |       , acExpiry = CTime x
47 |       }
48 | 
49 | cookieDecode :: ByteString -> ByteString -> Either String AuthCookie
50 | cookieDecode key d = State.decode key d >>= DS.decode
51 | 
52 | cookieEncode :: ByteString -> AuthCookie -> ByteString
53 | cookieEncode key = State.encode key . DS.encode
54 | 
55 | getEmail :: AuthUser -> Text
56 | getEmail = decodeUtf8 . auEmail
57 | 
58 | getEmailUtf8 :: AuthUser -> ByteString
59 | getEmailUtf8 = auEmail
60 | 
61 | getGivenNameUtf8 :: AuthUser -> ByteString
62 | getGivenNameUtf8 = auGivenName
63 | 
64 | getFamilyNameUtf8 :: AuthUser -> ByteString
65 | getFamilyNameUtf8 = auFamilyName
66 | 
67 | newUser :: Text -> AuthUser
68 | newUser email =
69 |   AuthUser
70 |   { auEmail = encodeUtf8 . toLower . strip $ email
71 |   , auGivenName = ""
72 |   , auFamilyName = ""
73 |   }
74 | 
75 | setGivenName :: Text -> AuthUser -> AuthUser
76 | setGivenName given au = au {auGivenName = encodeUtf8 . strip $ given}
77 | 
78 | setFamilyName :: Text -> AuthUser -> AuthUser
79 | setFamilyName family au = au {auFamilyName = encodeUtf8 . strip $ family}
80 | 


--------------------------------------------------------------------------------
/src/Sproxy/Application/OAuth2.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | 
 3 | module Sproxy.Application.OAuth2
 4 |   ( providers
 5 |   ) where
 6 | 
 7 | import Data.HashMap.Strict (HashMap, fromList)
 8 | import Data.Text (Text)
 9 | 
10 | import Sproxy.Application.OAuth2.Common (OAuth2Provider)
11 | import qualified Sproxy.Application.OAuth2.Google as Google
12 | import qualified Sproxy.Application.OAuth2.LinkedIn as LinkedIn
13 | import qualified Sproxy.Application.OAuth2.Yandex as Yandex
14 | 
15 | providers :: HashMap Text OAuth2Provider
16 | providers =
17 |   fromList
18 |     [ ("google", Google.provider)
19 |     , ("linkedin", LinkedIn.provider)
20 |     , ("yandex", Yandex.provider)
21 |     ]
22 | 


--------------------------------------------------------------------------------
/src/Sproxy/Application/OAuth2/Common.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | 
 3 | module Sproxy.Application.OAuth2.Common
 4 |   ( AccessTokenBody(..)
 5 |   , OAuth2Client(..)
 6 |   , OAuth2Provider
 7 |   ) where
 8 | 
 9 | import Control.Applicative (empty)
10 | import Data.Aeson (FromJSON, Value(Object), (.:), parseJSON)
11 | import Data.ByteString (ByteString)
12 | import Data.Text (Text)
13 | 
14 | import Sproxy.Application.Cookie (AuthUser)
15 | 
16 | data OAuth2Client = OAuth2Client
17 |   { oauth2Description :: String
18 |   , oauth2AuthorizeURL :: ByteString -- state
19 |                            -> ByteString -- redirect url
20 |                                -> ByteString
21 |   , oauth2Authenticate :: ByteString -- code
22 |                            -> ByteString -- redirect url
23 |                                -> IO AuthUser
24 |   }
25 | 
26 | type OAuth2Provider = (ByteString, ByteString) -> OAuth2Client
27 | 
28 | -- | RFC6749. We ignore optional token_type ("Bearer" from Google, omitted by LinkedIn)
29 | --   and expires_in because we don't use them, *and* expires_in creates troubles:
30 | --   it's an integer from Google and string from LinkedIn (sic!)
31 | data AccessTokenBody = AccessTokenBody
32 |   { accessToken :: Text
33 |   } deriving (Eq, Show)
34 | 
35 | instance FromJSON AccessTokenBody where
36 |   parseJSON (Object v) = AccessTokenBody <$> v .: "access_token"
37 |   parseJSON _ = empty
38 | 


--------------------------------------------------------------------------------
/src/Sproxy/Application/OAuth2/Google.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DeriveDataTypeable #-}
 2 | {-# LANGUAGE OverloadedStrings #-}
 3 | 
 4 | module Sproxy.Application.OAuth2.Google
 5 |   ( provider
 6 |   ) where
 7 | 
 8 | import Control.Applicative (empty)
 9 | import Control.Exception (Exception, throwIO)
10 | import Data.Aeson
11 |        (FromJSON, Value(Object), (.:), decode, parseJSON)
12 | import Data.ByteString.Lazy (ByteString)
13 | import Data.Monoid ((<>))
14 | import Data.Text (Text, unpack)
15 | import Data.Typeable (Typeable)
16 | import qualified Network.HTTP.Conduit as H
17 | import Network.HTTP.Types.URI (urlEncode)
18 | 
19 | import Sproxy.Application.Cookie
20 |        (newUser, setFamilyName, setGivenName)
21 | import Sproxy.Application.OAuth2.Common
22 |        (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider)
23 | 
24 | provider :: OAuth2Provider
25 | provider (client_id, client_secret) =
26 |   OAuth2Client
27 |   { oauth2Description = "Google"
28 |   , oauth2AuthorizeURL =
29 |       \state redirect_uri ->
30 |         "https://accounts.google.com/o/oauth2/v2/auth" <> "?scope=" <>
31 |         urlEncode
32 |           True
33 |           "https://www.googleapis.com/auth/userinfo.email https://www.googleapis.com/auth/userinfo.profile" <>
34 |         "&client_id=" <>
35 |         urlEncode True client_id <>
36 |         "&prompt=select_account" <>
37 |         "&redirect_uri=" <>
38 |         urlEncode True redirect_uri <>
39 |         "&response_type=code" <>
40 |         "&state=" <>
41 |         urlEncode True state
42 |   , oauth2Authenticate =
43 |       \code redirect_uri -> do
44 |         let treq =
45 |               H.urlEncodedBody
46 |                 [ ("client_id", client_id)
47 |                 , ("client_secret", client_secret)
48 |                 , ("code", code)
49 |                 , ("grant_type", "authorization_code")
50 |                 , ("redirect_uri", redirect_uri)
51 |                 ] $
52 |               H.parseRequest_ "POST https://www.googleapis.com/oauth2/v4/token"
53 |         mgr <- H.newManager H.tlsManagerSettings
54 |         tresp <- H.httpLbs treq mgr
55 |         case decode $ H.responseBody tresp of
56 |           Nothing -> throwIO $ GoogleException tresp
57 |           Just atResp -> do
58 |             ureq <-
59 |               H.parseRequest $
60 |               unpack
61 |                 ("https://www.googleapis.com/oauth2/v1/userinfo?access_token=" <>
62 |                  accessToken atResp)
63 |             uresp <- H.httpLbs ureq mgr
64 |             case decode $ H.responseBody uresp of
65 |               Nothing -> throwIO $ GoogleException uresp
66 |               Just u ->
67 |                 return $
68 |                 setFamilyName (familyName u) $
69 |                 setGivenName (givenName u) $ newUser (email u)
70 |   }
71 | 
72 | data GoogleException =
73 |   GoogleException (H.Response ByteString)
74 |   deriving (Show, Typeable)
75 | 
76 | instance Exception GoogleException
77 | 
78 | data GoogleUserInfo = GoogleUserInfo
79 |   { email :: Text
80 |   , givenName :: Text
81 |   , familyName :: Text
82 |   } deriving (Eq, Show)
83 | 
84 | instance FromJSON GoogleUserInfo where
85 |   parseJSON (Object v) =
86 |     GoogleUserInfo <$> v .: "email" <*> v .: "given_name" <*> v .: "family_name"
87 |   parseJSON _ = empty
88 | 


--------------------------------------------------------------------------------
/src/Sproxy/Application/OAuth2/LinkedIn.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DeriveDataTypeable #-}
 2 | {-# LANGUAGE OverloadedStrings #-}
 3 | 
 4 | module Sproxy.Application.OAuth2.LinkedIn
 5 |   ( provider
 6 |   ) where
 7 | 
 8 | import Control.Applicative (empty)
 9 | import Control.Exception (Exception, throwIO)
10 | import Data.Aeson
11 |        (FromJSON, Value(Object), (.:), decode, parseJSON)
12 | import Data.ByteString.Lazy (ByteString)
13 | import Data.Monoid ((<>))
14 | import Data.Text (Text)
15 | import Data.Text.Encoding (encodeUtf8)
16 | import Data.Typeable (Typeable)
17 | import qualified Network.HTTP.Conduit as H
18 | import Network.HTTP.Types.URI (urlEncode)
19 | 
20 | import Sproxy.Application.Cookie
21 |        (newUser, setFamilyName, setGivenName)
22 | import Sproxy.Application.OAuth2.Common
23 |        (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider)
24 | 
25 | provider :: OAuth2Provider
26 | provider (client_id, client_secret) =
27 |   OAuth2Client
28 |   { oauth2Description = "LinkedIn"
29 |   , oauth2AuthorizeURL =
30 |       \state redirect_uri ->
31 |         "https://www.linkedin.com/oauth/v2/authorization" <>
32 |         "?scope=r_basicprofile%20r_emailaddress" <>
33 |         "&client_id=" <>
34 |         urlEncode True client_id <>
35 |         "&redirect_uri=" <>
36 |         urlEncode True redirect_uri <>
37 |         "&response_type=code" <>
38 |         "&state=" <>
39 |         urlEncode True state
40 |   , oauth2Authenticate =
41 |       \code redirect_uri -> do
42 |         let treq =
43 |               H.urlEncodedBody
44 |                 [ ("client_id", client_id)
45 |                 , ("client_secret", client_secret)
46 |                 , ("code", code)
47 |                 , ("grant_type", "authorization_code")
48 |                 , ("redirect_uri", redirect_uri)
49 |                 ] $
50 |               H.parseRequest_
51 |                 "POST https://www.linkedin.com/oauth/v2/accessToken"
52 |         mgr <- H.newManager H.tlsManagerSettings
53 |         tresp <- H.httpLbs treq mgr
54 |         case decode $ H.responseBody tresp of
55 |           Nothing -> throwIO $ LinkedInException tresp
56 |           Just atResp -> do
57 |             let ureq =
58 |                   (H.parseRequest_
59 |                      "https://api.linkedin.com/v1/people/\
60 |                 \~:(email-address,first-name,last-name)?format=json")
61 |                   { H.requestHeaders =
62 |                       [ ( "Authorization"
63 |                         , "Bearer " <> encodeUtf8 (accessToken atResp))
64 |                       ]
65 |                   }
66 |             uresp <- H.httpLbs ureq mgr
67 |             case decode $ H.responseBody uresp of
68 |               Nothing -> throwIO $ LinkedInException uresp
69 |               Just u ->
70 |                 return $
71 |                 setFamilyName (lastName u) $
72 |                 setGivenName (firstName u) $ newUser (emailAddress u)
73 |   }
74 | 
75 | data LinkedInException =
76 |   LinkedInException (H.Response ByteString)
77 |   deriving (Show, Typeable)
78 | 
79 | instance Exception LinkedInException
80 | 
81 | data LinkedInUserInfo = LinkedInUserInfo
82 |   { emailAddress :: Text
83 |   , firstName :: Text
84 |   , lastName :: Text
85 |   } deriving (Eq, Show)
86 | 
87 | instance FromJSON LinkedInUserInfo where
88 |   parseJSON (Object v) =
89 |     LinkedInUserInfo <$> v .: "emailAddress" <*> v .: "firstName" <*>
90 |     v .: "lastName"
91 |   parseJSON _ = empty
92 | 


--------------------------------------------------------------------------------
/src/Sproxy/Application/OAuth2/Yandex.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE DeriveDataTypeable #-}
 2 | {-# LANGUAGE OverloadedStrings #-}
 3 | 
 4 | module Sproxy.Application.OAuth2.Yandex
 5 |   ( provider
 6 |   ) where
 7 | 
 8 | import Control.Applicative (empty)
 9 | import Control.Exception (Exception, throwIO)
10 | import Data.Aeson
11 |        (FromJSON, Value(Object), (.:), decode, parseJSON)
12 | import Data.ByteString.Lazy (ByteString)
13 | import Data.Monoid ((<>))
14 | import Data.Text (Text)
15 | import Data.Text.Encoding (encodeUtf8)
16 | import Data.Typeable (Typeable)
17 | import qualified Network.HTTP.Conduit as H
18 | import Network.HTTP.Types.URI (urlEncode)
19 | 
20 | import Sproxy.Application.Cookie
21 |        (newUser, setFamilyName, setGivenName)
22 | import Sproxy.Application.OAuth2.Common
23 |        (AccessTokenBody(accessToken), OAuth2Client(..), OAuth2Provider)
24 | 
25 | provider :: OAuth2Provider
26 | provider (client_id, client_secret) =
27 |   OAuth2Client
28 |   { oauth2Description = "Yandex"
29 |   , oauth2AuthorizeURL =
30 |       \state _redirect_uri ->
31 |         "https://oauth.yandex.ru/authorize" <> "?state=" <> urlEncode True state <>
32 |         "&client_id=" <>
33 |         urlEncode True client_id <>
34 |         "&response_type=code" <>
35 |         "&force_confirm=yes"
36 |   , oauth2Authenticate =
37 |       \code _redirect_uri -> do
38 |         let treq =
39 |               H.urlEncodedBody
40 |                 [ ("grant_type", "authorization_code")
41 |                 , ("client_id", client_id)
42 |                 , ("client_secret", client_secret)
43 |                 , ("code", code)
44 |                 ] $
45 |               H.parseRequest_ "POST https://oauth.yandex.ru/token"
46 |         mgr <- H.newManager H.tlsManagerSettings
47 |         tresp <- H.httpLbs treq mgr
48 |         case decode $ H.responseBody tresp of
49 |           Nothing -> throwIO $ YandexException tresp
50 |           Just atResp -> do
51 |             let ureq =
52 |                   (H.parseRequest_ "https://login.yandex.ru/info?format=json")
53 |                   { H.requestHeaders =
54 |                       [ ( "Authorization"
55 |                         , "OAuth " <> encodeUtf8 (accessToken atResp))
56 |                       ]
57 |                   }
58 |             uresp <- H.httpLbs ureq mgr
59 |             case decode $ H.responseBody uresp of
60 |               Nothing -> throwIO $ YandexException uresp
61 |               Just u ->
62 |                 return $
63 |                 setFamilyName (lastName u) $
64 |                 setGivenName (firstName u) $ newUser (defaultEmail u)
65 |   }
66 | 
67 | data YandexException =
68 |   YandexException (H.Response ByteString)
69 |   deriving (Show, Typeable)
70 | 
71 | instance Exception YandexException
72 | 
73 | data YandexUserInfo = YandexUserInfo
74 |   { defaultEmail :: Text
75 |   , firstName :: Text
76 |   , lastName :: Text
77 |   } deriving (Eq, Show)
78 | 
79 | instance FromJSON YandexUserInfo where
80 |   parseJSON (Object v) =
81 |     YandexUserInfo <$> v .: "default_email" <*> v .: "first_name" <*>
82 |     v .: "last_name"
83 |   parseJSON _ = empty
84 | 


--------------------------------------------------------------------------------
/src/Sproxy/Application/State.hs:
--------------------------------------------------------------------------------
 1 | module Sproxy.Application.State
 2 |   ( decode
 3 |   , encode
 4 |   ) where
 5 | 
 6 | import Data.ByteString (ByteString)
 7 | import qualified Data.ByteString.Base64 as Base64
 8 | import Data.ByteString.Lazy (fromStrict, toStrict)
 9 | import Data.Digest.Pure.SHA (bytestringDigest, hmacSha1)
10 | import qualified Data.Serialize as DS
11 | 
12 | -- FIXME: Compress / decompress ?
13 | encode :: ByteString -> ByteString -> ByteString
14 | encode key payload = Base64.encode . DS.encode $ (payload, digest key payload)
15 | 
16 | decode :: ByteString -> ByteString -> Either String ByteString
17 | decode key d = do
18 |   (payload, dgst) <- DS.decode =<< Base64.decode d
19 |   if dgst /= digest key payload
20 |     then Left "junk"
21 |     else Right payload
22 | 
23 | digest :: ByteString -> ByteString -> ByteString
24 | digest key payload =
25 |   toStrict . bytestringDigest $ hmacSha1 (fromStrict key) (fromStrict payload)
26 | 


--------------------------------------------------------------------------------
/src/Sproxy/Config.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | 
 3 | module Sproxy.Config
 4 |   ( BackendConf(..)
 5 |   , ConfigFile(..)
 6 |   , OAuth2Conf(..)
 7 |   ) where
 8 | 
 9 | import Control.Applicative (empty)
10 | import Data.Aeson (FromJSON, parseJSON)
11 | import Data.HashMap.Strict (HashMap)
12 | import Data.Int (Int64)
13 | import Data.Text (Text)
14 | import Data.Word (Word16)
15 | import Data.Yaml (Value(Object), (.!=), (.:), (.:?))
16 | 
17 | import Sproxy.Logging (LogLevel(Debug))
18 | 
19 | data ConfigFile = ConfigFile
20 |   { cfListen :: Word16
21 |   , cfSsl :: Bool
22 |   , cfUser :: String
23 |   , cfHome :: FilePath
24 |   , cfLogLevel :: LogLevel
25 |   , cfSslCert :: Maybe FilePath
26 |   , cfSslKey :: Maybe FilePath
27 |   , cfSslCertChain :: [FilePath]
28 |   , cfKey :: Maybe String
29 |   , cfListen80 :: Maybe Bool
30 |   , cfHttpsPort :: Maybe Word16
31 |   , cfBackends :: [BackendConf]
32 |   , cfOAuth2 :: HashMap Text OAuth2Conf
33 |   , cfDataFile :: Maybe FilePath
34 |   , cfDatabase :: Maybe String
35 |   , cfPgPassFile :: Maybe FilePath
36 |   , cfHTTP2 :: Bool
37 |   } deriving (Show)
38 | 
39 | instance FromJSON ConfigFile where
40 |   parseJSON (Object m) =
41 |     ConfigFile <$> m .:? "listen" .!= 443 <*> m .:? "ssl" .!= True <*>
42 |     m .:? "user" .!= "sproxy" <*>
43 |     m .:? "home" .!= "." <*>
44 |     m .:? "log_level" .!= Debug <*>
45 |     m .:? "ssl_cert" <*>
46 |     m .:? "ssl_key" <*>
47 |     m .:? "ssl_cert_chain" .!= [] <*>
48 |     m .:? "key" <*>
49 |     m .:? "listen80" <*>
50 |     m .:? "https_port" <*>
51 |     m .: "backends" <*>
52 |     m .: "oauth2" <*>
53 |     m .:? "datafile" <*>
54 |     m .:? "database" <*>
55 |     m .:? "pgpassfile" <*>
56 |     m .:? "http2" .!= True
57 |   parseJSON _ = empty
58 | 
59 | data BackendConf = BackendConf
60 |   { beName :: String
61 |   , beAddress :: String
62 |   , bePort :: Maybe Word16
63 |   , beSocket :: Maybe FilePath
64 |   , beCookieName :: String
65 |   , beCookieDomain :: Maybe String
66 |   , beCookieMaxAge :: Int64
67 |   , beConnCount :: Int
68 |   } deriving (Show)
69 | 
70 | instance FromJSON BackendConf where
71 |   parseJSON (Object m) =
72 |     BackendConf <$> m .:? "name" .!= "*" <*> m .:? "address" .!= "127.0.0.1" <*>
73 |     m .:? "port" <*>
74 |     m .:? "socket" <*>
75 |     m .:? "cookie_name" .!= "sproxy" <*>
76 |     m .:? "cookie_domain" <*>
77 |     m .:? "cookie_max_age" .!= (7 * 24 * 60 * 60) <*>
78 |     m .:? "conn_count" .!= 32
79 |   parseJSON _ = empty
80 | 
81 | data OAuth2Conf = OAuth2Conf
82 |   { oa2ClientId :: String
83 |   , oa2ClientSecret :: String
84 |   } deriving (Show)
85 | 
86 | instance FromJSON OAuth2Conf where
87 |   parseJSON (Object m) =
88 |     OAuth2Conf <$> m .: "client_id" <*> m .: "client_secret"
89 |   parseJSON _ = empty
90 | 


--------------------------------------------------------------------------------
/src/Sproxy/Logging.hs:
--------------------------------------------------------------------------------
  1 | module Sproxy.Logging
  2 |   ( LogLevel(..)
  3 |   , debug
  4 |   , error
  5 |   , info
  6 |   , level
  7 |   , start
  8 |   , warn
  9 |   ) where
 10 | 
 11 | import Prelude hiding (error)
 12 | 
 13 | import Control.Applicative (empty)
 14 | import Control.Concurrent (forkIO)
 15 | import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)
 16 | import Control.Monad (forever, when)
 17 | import Data.Aeson (FromJSON, ToJSON)
 18 | import qualified Data.Aeson as JSON
 19 | import Data.Char (toLower)
 20 | import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 21 | import qualified Data.Text as T
 22 | import System.IO (hPrint, stderr)
 23 | import System.IO.Unsafe (unsafePerformIO)
 24 | import Text.Read (readMaybe)
 25 | 
 26 | start :: LogLevel -> IO ()
 27 | start None = return ()
 28 | start lvl = do
 29 |   writeIORef logLevel lvl
 30 |   ch <- readIORef chanRef
 31 |   _ <- forkIO . forever $ readChan ch >>= hPrint stderr
 32 |   return ()
 33 | 
 34 | info :: String -> IO ()
 35 | info = send . Message Info
 36 | 
 37 | warn :: String -> IO ()
 38 | warn = send . Message Warning
 39 | 
 40 | error :: String -> IO ()
 41 | error = send . Message Error
 42 | 
 43 | debug :: String -> IO ()
 44 | debug = send . Message Debug
 45 | 
 46 | send :: Message -> IO ()
 47 | send msg@(Message l _) = do
 48 |   lvl <- level
 49 |   when (l <= lvl) $ do
 50 |     ch <- readIORef chanRef
 51 |     writeChan ch msg
 52 | 
 53 | {-# NOINLINE chanRef #-}
 54 | chanRef :: IORef (Chan Message)
 55 | chanRef = unsafePerformIO (newChan >>= newIORef)
 56 | 
 57 | {-# NOINLINE logLevel #-}
 58 | logLevel :: IORef LogLevel
 59 | logLevel = unsafePerformIO (newIORef None)
 60 | 
 61 | level :: IO LogLevel
 62 | level = readIORef logLevel
 63 | 
 64 | data LogLevel
 65 |   = None
 66 |   | Error
 67 |   | Warning
 68 |   | Info
 69 |   | Debug
 70 |   deriving (Enum, Ord, Eq)
 71 | 
 72 | instance Show LogLevel where
 73 |   show None = "NONE"
 74 |   show Error = "ERROR"
 75 |   show Warning = "WARN"
 76 |   show Info = "INFO"
 77 |   show Debug = "DEBUG"
 78 | 
 79 | instance Read LogLevel where
 80 |   readsPrec _ s
 81 |     | l == "none" = [(None, "")]
 82 |     | l == "error" = [(Error, "")]
 83 |     | l == "warn" = [(Warning, "")]
 84 |     | l == "info" = [(Info, "")]
 85 |     | l == "debug" = [(Debug, "")]
 86 |     | otherwise = []
 87 |     where
 88 |       l = map toLower s
 89 | 
 90 | instance ToJSON LogLevel where
 91 |   toJSON = JSON.String . T.pack . show
 92 | 
 93 | instance FromJSON LogLevel where
 94 |   parseJSON (JSON.String s) =
 95 |     maybe
 96 |       (fail $ "unknown log level: " ++ show s)
 97 |       return
 98 |       (readMaybe . T.unpack $ s)
 99 |   parseJSON _ = empty
100 | 
101 | data Message =
102 |   Message LogLevel
103 |           String
104 | 
105 | instance Show Message where
106 |   show (Message lvl str) = show lvl ++ ": " ++ str
107 | 


--------------------------------------------------------------------------------
/src/Sproxy/Server.hs:
--------------------------------------------------------------------------------
  1 | module Sproxy.Server
  2 |   ( server
  3 |   ) where
  4 | 
  5 | import Control.Concurrent (forkIO)
  6 | import Control.Exception (bracketOnError)
  7 | import Control.Monad (void, when)
  8 | import Data.ByteString.Char8 (pack)
  9 | import Data.HashMap.Strict as HM (fromList, lookup, toList)
 10 | import Data.Maybe (fromMaybe)
 11 | import Data.Text (Text)
 12 | import Data.Word (Word16)
 13 | import Data.Yaml.Include (decodeFileEither)
 14 | import Network.HTTP.Client
 15 |        (Manager, ManagerSettings(..), defaultManagerSettings, newManager,
 16 |         socketConnection)
 17 | import Network.HTTP.Client.Internal (Connection)
 18 | import Network.Socket
 19 |        (Family(AF_INET, AF_UNIX), SockAddr(SockAddrInet, SockAddrUnix),
 20 |         Socket, SocketOption(ReuseAddr), SocketType(Stream), bind, close,
 21 |         connect, inet_addr, listen, maxListenQueue, setSocketOption,
 22 |         socket)
 23 | import Network.Wai (Application)
 24 | import Network.Wai.Handler.Warp
 25 |        (Settings, defaultSettings, runSettingsSocket, setHTTP2Disabled,
 26 |         setOnException)
 27 | import Network.Wai.Handler.WarpTLS (runTLSSocket, tlsSettingsChain)
 28 | import System.Entropy (getEntropy)
 29 | import System.Environment (setEnv)
 30 | import System.Exit (exitFailure)
 31 | import System.FilePath.Glob (compile)
 32 | import System.IO (hPutStrLn, stderr)
 33 | import System.Posix.User
 34 |        (GroupEntry(..), UserEntry(..), getAllGroupEntries, getRealUserID,
 35 |         getUserEntryForName, setGroupID, setGroups, setUserID)
 36 | 
 37 | import Sproxy.Application (redirect, sproxy)
 38 | import qualified Sproxy.Application.OAuth2 as OAuth2
 39 | import Sproxy.Application.OAuth2.Common (OAuth2Client)
 40 | import Sproxy.Config
 41 |        (BackendConf(..), ConfigFile(..), OAuth2Conf(..))
 42 | import qualified Sproxy.Logging as Log
 43 | import qualified Sproxy.Server.DB as DB
 44 | 
 45 | {- TODO:
 46 |  - Log.error && exitFailure should be replaced
 47 |  - by Log.fatal && wait for logger thread to print && exitFailure
 48 | -}
 49 | server :: FilePath -> IO ()
 50 | server configFile = do
 51 |   cf <- readConfigFile configFile
 52 |   Log.start $ cfLogLevel cf
 53 |   sock <- socket AF_INET Stream 0
 54 |   setSocketOption sock ReuseAddr 1
 55 |   bind sock $ SockAddrInet (fromIntegral $ cfListen cf) 0
 56 |   maybe80 <-
 57 |     if fromMaybe (443 == cfListen cf) (cfListen80 cf)
 58 |       then do
 59 |         sock80 <- socket AF_INET Stream 0
 60 |         setSocketOption sock80 ReuseAddr 1
 61 |         bind sock80 $ SockAddrInet 80 0
 62 |         return (Just sock80)
 63 |       else return Nothing
 64 |   uid <- getRealUserID
 65 |   when (0 == uid) $ do
 66 |     let user = cfUser cf
 67 |     Log.info $ "switching to user " ++ show user
 68 |     u <- getUserEntryForName user
 69 |     groupIDs <-
 70 |       map groupID . filter (elem user . groupMembers) <$> getAllGroupEntries
 71 |     setGroups groupIDs
 72 |     setGroupID $ userGroupID u
 73 |     setUserID $ userID u
 74 |   ds <- newDataSource cf
 75 |   db <- DB.start (cfHome cf) ds
 76 |   key <-
 77 |     maybe
 78 |       (Log.info "using new random key" >> getEntropy 32)
 79 |       (return . pack)
 80 |       (cfKey cf)
 81 |   let settings =
 82 |         (if cfHTTP2 cf
 83 |            then id
 84 |            else setHTTP2Disabled) $
 85 |         setOnException (\_ _ -> return ()) defaultSettings
 86 |   oauth2clients <-
 87 |     HM.fromList <$> mapM newOAuth2Client (HM.toList (cfOAuth2 cf))
 88 |   backends <-
 89 |     mapM
 90 |       (\be -> do
 91 |          m <- newBackendManager be
 92 |          return (compile $ beName be, be, m)) $
 93 |     cfBackends cf
 94 |   warpServer <- newServer cf
 95 |   case maybe80 of
 96 |     Nothing -> return ()
 97 |     Just sock80 -> do
 98 |       let httpsPort = fromMaybe (cfListen cf) (cfHttpsPort cf)
 99 |       Log.info "listening on port 80 (HTTP redirect)"
100 |       listen sock80 maxListenQueue
101 |       void . forkIO $ runSettingsSocket settings sock80 (redirect httpsPort)
102 |   -- XXX 2048 is from bindPortTCP from streaming-commons used internally by runTLS.
103 |   -- XXX Since we don't call runTLS, we listen socket here with the same options.
104 |   Log.info $ "proxy listening on port " ++ show (cfListen cf)
105 |   listen sock (max 2048 maxListenQueue)
106 |   warpServer settings sock (sproxy key db oauth2clients backends)
107 | 
108 | newDataSource :: ConfigFile -> IO (Maybe DB.DataSource)
109 | newDataSource cf =
110 |   case (cfDataFile cf, cfDatabase cf) of
111 |     (Nothing, Just str) -> do
112 |       case cfPgPassFile cf of
113 |         Nothing -> return ()
114 |         Just f -> do
115 |           Log.info $ "pgpassfile: " ++ show f
116 |           setEnv "PGPASSFILE" f
117 |       return . Just $ DB.PostgreSQL str
118 |     (Just f, Nothing) -> return . Just $ DB.File f
119 |     (Nothing, Nothing) -> return Nothing
120 |     _ -> do
121 |       Log.error "only one data source can be used"
122 |       exitFailure
123 | 
124 | newOAuth2Client :: (Text, OAuth2Conf) -> IO (Text, OAuth2Client)
125 | newOAuth2Client (name, cfg) =
126 |   case HM.lookup name OAuth2.providers of
127 |     Nothing -> do
128 |       Log.error $ "OAuth2 provider " ++ show name ++ " is not supported"
129 |       exitFailure
130 |     Just provider -> do
131 |       Log.info $ "oauth2: adding " ++ show name
132 |       return (name, provider (client_id, client_secret))
133 |   where
134 |     client_id = pack $ oa2ClientId cfg
135 |     client_secret = pack $ oa2ClientSecret cfg
136 | 
137 | newBackendManager :: BackendConf -> IO Manager
138 | newBackendManager be = do
139 |   openConn <-
140 |     case (beSocket be, bePort be) of
141 |       (Just f, Nothing) -> do
142 |         Log.info $ "backend `" ++ beName be ++ "' on UNIX socket " ++ f
143 |         return $ openUnixSocketConnection f
144 |       (Nothing, Just n) -> do
145 |         Log.info $
146 |           "backend `" ++ beName be ++ "' on " ++ beAddress be ++ ":" ++ show n
147 |         return $ openTCPConnection (beAddress be) n
148 |       _ -> do
149 |         Log.error "either backend port number or UNIX socket path is required."
150 |         exitFailure
151 |   newManager
152 |     defaultManagerSettings
153 |     { managerRawConnection = return $ \_ _ _ -> openConn
154 |     , managerConnCount = beConnCount be
155 |     }
156 | 
157 | newServer :: ConfigFile -> IO (Settings -> Socket -> Application -> IO ())
158 | newServer cf
159 |   | cfSsl cf =
160 |     case (cfSslKey cf, cfSslCert cf) of
161 |       (Just k, Just c) ->
162 |         return $ runTLSSocket (tlsSettingsChain c (cfSslCertChain cf) k)
163 |       _ -> do
164 |         Log.error "missings SSL certificate"
165 |         exitFailure
166 |   | otherwise = do
167 |     Log.warn "not using SSL!"
168 |     return runSettingsSocket
169 | 
170 | openUnixSocketConnection :: FilePath -> IO Connection
171 | openUnixSocketConnection f =
172 |   bracketOnError
173 |     (socket AF_UNIX Stream 0)
174 |     close
175 |     (\s -> do
176 |        connect s (SockAddrUnix f)
177 |        socketConnection s 8192)
178 | 
179 | openTCPConnection :: String -> Word16 -> IO Connection
180 | openTCPConnection addr port =
181 |   bracketOnError
182 |     (socket AF_INET Stream 0)
183 |     close
184 |     (\s -> do
185 |        a <- inet_addr addr
186 |        connect s (SockAddrInet (fromIntegral port) a)
187 |        socketConnection s 8192)
188 | 
189 | readConfigFile :: FilePath -> IO ConfigFile
190 | readConfigFile f = do
191 |   r <- decodeFileEither f
192 |   case r of
193 |     Left e -> do
194 |       hPutStrLn stderr $ "FATAL: " ++ f ++ ": " ++ show e
195 |       exitFailure
196 |     Right cf -> return cf
197 | 


--------------------------------------------------------------------------------
/src/Sproxy/Server/DB.hs:
--------------------------------------------------------------------------------
  1 | {-# LANGUAGE OverloadedStrings #-}
  2 | {-# LANGUAGE QuasiQuotes #-}
  3 | 
  4 | module Sproxy.Server.DB
  5 |   ( Database
  6 |   , DataSource(..)
  7 |   , userAccess
  8 |   , userExists
  9 |   , userGroups
 10 |   , start
 11 |   ) where
 12 | 
 13 | import Control.Concurrent (forkIO, threadDelay)
 14 | import Control.Exception (SomeException, bracket, catch, finally)
 15 | import Control.Monad (filterM, forever, void)
 16 | import Data.ByteString.Char8 (pack)
 17 | import qualified Data.HashMap.Strict as HM
 18 | import Data.Pool (Pool, createPool, withResource)
 19 | import Data.Text (Text, toLower, unpack)
 20 | import Data.Yaml (decodeFileEither)
 21 | import qualified Database.PostgreSQL.Simple as PG
 22 | import Database.SQLite.Simple (NamedParam((:=)))
 23 | import qualified Database.SQLite.Simple as SQLite
 24 | import Text.InterpolatedString.Perl6 (q, qc)
 25 | 
 26 | import qualified Sproxy.Application.Access as A
 27 | import qualified Sproxy.Logging as Log
 28 | import Sproxy.Server.DB.DataFile
 29 |        (DataFile(..), GroupMember(..), GroupPrivilege(..),
 30 |         PrivilegeRule(..))
 31 | 
 32 | type Database = Pool SQLite.Connection
 33 | 
 34 | data DataSource
 35 |   = PostgreSQL String
 36 |   | File FilePath
 37 | 
 38 | {- TODO:
 39 |  - Hash remote tables and update the local only when the remote change
 40 |  - Switch to REGEX
 41 |  - Generalize sync procedures for different tables
 42 |  -}
 43 | start :: FilePath -> Maybe DataSource -> IO Database
 44 | start home ds = do
 45 |   Log.info $ "home directory: " ++ show home
 46 |   db <-
 47 |     createPool
 48 |       (do c <- SQLite.open $ home ++ "/sproxy.sqlite3"
 49 |           lvl <- Log.level
 50 |           SQLite.setTrace
 51 |             c
 52 |             (if lvl == Log.Debug
 53 |                then Just $ Log.debug . unpack
 54 |                else Nothing)
 55 |           return c)
 56 |       SQLite.close
 57 |       1 -- stripes
 58 |       3600 -- keep alive (seconds). FIXME: no much sense as it's a local file
 59 |       128 -- max connections. FIXME: make configurable?
 60 |   withResource db $ \c -> SQLite.execute_ c "PRAGMA journal_mode=WAL"
 61 |   populate db ds
 62 |   return db
 63 | 
 64 | userExists :: Database -> Text -> IO Bool
 65 | userExists db email = do
 66 |   r <-
 67 |     withResource db $ \c ->
 68 |       fmap SQLite.fromOnly <$>
 69 |       SQLite.queryNamed
 70 |         c
 71 |         "SELECT EXISTS (SELECT 1 FROM group_member WHERE :email LIKE email LIMIT 1)"
 72 |         [":email" := email]
 73 |   return $ head r
 74 | 
 75 | userGroups_ :: SQLite.Connection -> Text -> Text -> Text -> Text -> IO [Text]
 76 | userGroups_ c email domain path method =
 77 |   fmap SQLite.fromOnly <$>
 78 |   SQLite.queryNamed
 79 |     c
 80 |     [q|
 81 |     SELECT gm."group" FROM group_privilege gp JOIN group_member gm ON gm."group"  = gp."group"
 82 |     WHERE :email LIKE gm.email
 83 |     AND gp.domain = :domain
 84 |     AND gp.privilege IN (
 85 |       SELECT privilege FROM privilege_rule
 86 |       WHERE domain = :domain
 87 |       AND :path LIKE path
 88 |       AND method = :method
 89 |       ORDER BY length(path) - length(replace(path, '/', '')) DESC LIMIT 1
 90 |     )
 91 |   |]
 92 |     [ ":email" := email -- XXX always in lower case
 93 |     , ":domain" := toLower domain
 94 |     , ":path" := path
 95 |     , ":method" := method -- XXX case-sensitive by RFC2616
 96 |     ]
 97 | 
 98 | userAccess :: Database -> Text -> Text -> A.Inquiry -> IO [Text]
 99 | userAccess db email domain inq = do
100 |   let permitted c (_, qn) =
101 |         not . null <$> userGroups_ c email domain (A.path qn) (A.method qn)
102 |   map fst <$> withResource db (\c -> filterM (permitted c) (HM.toList inq))
103 | 
104 | userGroups :: Database -> Text -> Text -> Text -> Text -> IO [Text]
105 | userGroups db email domain path method =
106 |   withResource db $ \c -> userGroups_ c email domain path method
107 | 
108 | populate :: Database -> Maybe DataSource -> IO ()
109 | populate db Nothing = do
110 |   Log.warn "db: no data source defined"
111 |   withResource db $ \c ->
112 |     SQLite.withTransaction c $ do
113 |       createGroupMember c
114 |       createGroupPrivilege c
115 |       createPrivilegeRule c
116 | populate db (Just (File f)) = do
117 |   Log.info $ "db: reading " ++ show f
118 |   r <- decodeFileEither f
119 |   case r of
120 |     Left e -> Log.error $ f ++ ": " ++ show e
121 |     Right df ->
122 |       withResource db $ \c ->
123 |         SQLite.withTransaction c $ do
124 |           refreshGroupMembers c $ \st ->
125 |             mapM_
126 |               (\gm -> submit st (gmGroup gm, toLower $ gmEmail gm))
127 |               (groupMember df)
128 |           refreshGroupPrivileges c $ \st ->
129 |             mapM_
130 |               (\gp ->
131 |                  submit st (gpGroup gp, toLower $ gpDomain gp, gpPrivilege gp))
132 |               (groupPrivilege df)
133 |           refreshPrivilegeRule c $ \st ->
134 |             mapM_
135 |               (\pr ->
136 |                  submit
137 |                    st
138 |                    ( toLower $ prDomain pr
139 |                    , prPrivilege pr
140 |                    , prPath pr
141 |                    , prMethod pr))
142 |               (privilegeRule df)
143 | populate db (Just (PostgreSQL connstr)) =
144 |   void .
145 |   forkIO . forever . flip finally (7 `minutes` threadDelay) . logException $ do
146 |     Log.info $ "db: synchronizing with " ++ show connstr
147 |     withResource db $ \c ->
148 |       SQLite.withTransaction c $
149 |       bracket (PG.connectPostgreSQL $ pack connstr) PG.close $ \pg ->
150 |         PG.withTransaction pg $ do
151 |           Log.info "db: syncing group_member"
152 |           refreshGroupMembers c $ \st ->
153 |             PG.forEach_ pg [q|SELECT "group", lower(email) FROM group_member|] $ \r ->
154 |               submit st (r :: (Text, Text))
155 |           count c "group_member"
156 |           Log.info "db: syncing group_privilege"
157 |           refreshGroupPrivileges c $ \st ->
158 |             PG.forEach_
159 |               pg
160 |               [q|SELECT "group", lower(domain), privilege FROM group_privilege|] $ \r ->
161 |               submit st (r :: (Text, Text, Text))
162 |           count c "group_privilege"
163 |           Log.info "db: syncing privilege_rule"
164 |           refreshPrivilegeRule c $ \st ->
165 |             PG.forEach_
166 |               pg
167 |               [q|SELECT lower(domain), privilege, path, method FROM privilege_rule|] $ \r ->
168 |               submit st (r :: (Text, Text, Text, Text))
169 |           count c "privilege_rule"
170 | 
171 | -- FIXME short-cut for https://github.com/nurpax/sqlite-simple/issues/50
172 | -- FIXME nextRow is the only way to execute a prepared statement
173 | -- FIXME with bound parameters, but we don't expect any results.
174 | submit :: SQLite.ToRow values => SQLite.Statement -> values -> IO ()
175 | submit st v =
176 |   SQLite.withBind st v $ void (SQLite.nextRow st :: IO (Maybe [Int]))
177 | 
178 | createGroupMember :: SQLite.Connection -> IO ()
179 | createGroupMember c =
180 |   SQLite.execute_
181 |     c
182 |     [q|
183 |   CREATE TABLE IF NOT EXISTS group_member (
184 |     "group" TEXT,
185 |     email TEXT,
186 |     PRIMARY KEY ("group", email)
187 |   )
188 | |]
189 | 
190 | refreshGroupMembers :: SQLite.Connection -> (SQLite.Statement -> IO ()) -> IO ()
191 | refreshGroupMembers c a = do
192 |   SQLite.execute_ c "DROP TABLE IF EXISTS group_member"
193 |   createGroupMember c
194 |   SQLite.withStatement
195 |     c
196 |     [q|INSERT INTO group_member("group", email) VALUES (?, ?)|]
197 |     a
198 | 
199 | createGroupPrivilege :: SQLite.Connection -> IO ()
200 | createGroupPrivilege c =
201 |   SQLite.execute_
202 |     c
203 |     [q|
204 |   CREATE TABLE IF NOT EXISTS group_privilege (
205 |     "group" TEXT,
206 |     domain TEXT,
207 |     privilege TEXT,
208 |     PRIMARY KEY ("group", domain, privilege)
209 |   )
210 | |]
211 | 
212 | refreshGroupPrivileges ::
213 |      SQLite.Connection -> (SQLite.Statement -> IO ()) -> IO ()
214 | refreshGroupPrivileges c a = do
215 |   SQLite.execute_ c "DROP TABLE IF EXISTS group_privilege"
216 |   createGroupPrivilege c
217 |   SQLite.withStatement
218 |     c
219 |     [q|INSERT INTO group_privilege("group", domain, privilege) VALUES (?, ?, ?)|]
220 |     a
221 | 
222 | createPrivilegeRule :: SQLite.Connection -> IO ()
223 | createPrivilegeRule c =
224 |   SQLite.execute_
225 |     c
226 |     [q|
227 |   CREATE TABLE IF NOT EXISTS privilege_rule (
228 |     domain TEXT,
229 |     privilege TEXT,
230 |     path TEXT,
231 |     method TEXT,
232 |     PRIMARY KEY (domain, path, method)
233 |   )
234 | |]
235 | 
236 | refreshPrivilegeRule ::
237 |      SQLite.Connection -> (SQLite.Statement -> IO ()) -> IO ()
238 | refreshPrivilegeRule c a = do
239 |   SQLite.execute_ c "DROP TABLE IF EXISTS privilege_rule"
240 |   createPrivilegeRule c
241 |   SQLite.withStatement
242 |     c
243 |     [q|INSERT INTO privilege_rule(domain, privilege, path, method) VALUES (?, ?, ?, ?)|]
244 |     a
245 | 
246 | count :: SQLite.Connection -> String -> IO ()
247 | count c table = do
248 |   r <-
249 |     fmap SQLite.fromOnly <$> SQLite.query_ c [qc|SELECT COUNT(*) FROM {table}|]
250 |   Log.info $ "db: " ++ table ++ " rows: " ++ show (head r :: Integer)
251 | 
252 | logException :: IO () -> IO ()
253 | logException a = catch a $ \e -> Log.error $ "db: " ++ show (e :: SomeException)
254 | 
255 | minutes :: Int -> (Int -> IO ()) -> IO ()
256 | minutes us f = f $ us * 60 * 1000000
257 | 


--------------------------------------------------------------------------------
/src/Sproxy/Server/DB/DataFile.hs:
--------------------------------------------------------------------------------
 1 | {-# LANGUAGE OverloadedStrings #-}
 2 | 
 3 | module Sproxy.Server.DB.DataFile
 4 |   ( DataFile(..)
 5 |   , GroupMember(..)
 6 |   , GroupPrivilege(..)
 7 |   , PrivilegeRule(..)
 8 |   ) where
 9 | 
10 | import Control.Applicative (empty)
11 | import Data.Aeson (FromJSON, parseJSON)
12 | import Data.Text (Text)
13 | import Data.Yaml (Value(Object), (.:))
14 | 
15 | data DataFile = DataFile
16 |   { groupMember :: [GroupMember]
17 |   , groupPrivilege :: [GroupPrivilege]
18 |   , privilegeRule :: [PrivilegeRule]
19 |   } deriving (Show)
20 | 
21 | instance FromJSON DataFile where
22 |   parseJSON (Object m) =
23 |     DataFile <$> m .: "group_member" <*> m .: "group_privilege" <*>
24 |     m .: "privilege_rule"
25 |   parseJSON _ = empty
26 | 
27 | data GroupMember = GroupMember
28 |   { gmGroup :: Text
29 |   , gmEmail :: Text
30 |   } deriving (Show)
31 | 
32 | instance FromJSON GroupMember where
33 |   parseJSON (Object m) = GroupMember <$> m .: "group" <*> m .: "email"
34 |   parseJSON _ = empty
35 | 
36 | data GroupPrivilege = GroupPrivilege
37 |   { gpGroup :: Text
38 |   , gpDomain :: Text
39 |   , gpPrivilege :: Text
40 |   } deriving (Show)
41 | 
42 | instance FromJSON GroupPrivilege where
43 |   parseJSON (Object m) =
44 |     GroupPrivilege <$> m .: "group" <*> m .: "domain" <*> m .: "privilege"
45 |   parseJSON _ = empty
46 | 
47 | data PrivilegeRule = PrivilegeRule
48 |   { prDomain :: Text
49 |   , prPrivilege :: Text
50 |   , prPath :: Text
51 |   , prMethod :: Text
52 |   } deriving (Show)
53 | 
54 | instance FromJSON PrivilegeRule where
55 |   parseJSON (Object m) =
56 |     PrivilegeRule <$> m .: "domain" <*> m .: "privilege" <*> m .: "path" <*>
57 |     m .: "method"
58 |   parseJSON _ = empty
59 | 


--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
 1 | resolver: lts-9.0
 2 | system-ghc: true
 3 | install-ghc: false
 4 | packages:
 5 | 
 6 | - '.'
 7 | 
 8 | extra-deps: []
 9 | 
10 | flags: {}
11 | 
12 | extra-package-dbs: []
13 | 
14 | 


--------------------------------------------------------------------------------