├── src ├── DB │ ├── Helpers.hs │ ├── ContributorCall.hs │ ├── Repository.hs │ ├── User.hs │ └── Organisation.hs ├── DB.hs ├── Web │ ├── Sessions │ │ ├── Types.hs │ │ └── Server.hs │ ├── Helpers.hs │ ├── Middleware.hs │ ├── Router.hs │ ├── Types.hs │ ├── FlashAlerts.hs │ ├── Form.hs │ ├── Form │ │ └── Types.hs │ └── Sessions.hs ├── Handler │ ├── Signup.hs │ ├── Login.hs │ ├── User.hs │ ├── Home.hs │ ├── Login │ │ └── Signin.hs │ └── Account │ │ └── Create.hs ├── Templates │ ├── Types.hs │ ├── Helpers.hs │ ├── Partials │ │ └── FlashAlerts.hs │ ├── Error │ │ └── 500.html │ ├── Account │ │ └── signup.html │ └── Home │ │ └── index.html ├── ImportYesod.hs ├── Handler.hs ├── Model │ └── UserModel.hs ├── Templates.hs ├── Environment.hs ├── Server.hs └── Foundation.hs ├── CHANGELOG.md ├── assets ├── js │ └── index.js ├── images │ └── hackage.png ├── tailwind.config.js ├── webpack │ ├── postcss.config.js │ ├── plugins │ │ └── bundle-hash-plugin.js │ └── webpack.config.js ├── css │ └── style.css ├── package.json └── layout.jinja.template ├── app └── Main.hs ├── resources └── matchmaker-frontpage.png ├── .sosrc ├── .github ├── ISSUE_TEMPLATE.md └── workflows │ ├── stylish-haskell-runner.sh │ ├── hlint-runner.sh │ ├── install-nix.sh │ └── ci.yml ├── migrations ├── 20210423115240_organisations.sql ├── 20210423114034_users.sql ├── 20210423181549_contributor_calls.sql ├── 20210423115352_user_organisation.sql └── 20210423181548_repositories.sql ├── cabal.project ├── test ├── DB │ ├── SpecHelpers.hs │ ├── UserSpec.hs │ └── OrganisationSpec.hs ├── Main.hs ├── Web │ └── AccountCreationSpec.hs └── fixtures.sql ├── .gitignore ├── .editorconfig ├── environment.sh ├── LICENSE ├── shell.nix ├── README.md ├── Makefile ├── matchmaker.cabal ├── .stylish-haskell.yaml └── cabal.project.freeze /src/DB/Helpers.hs: -------------------------------------------------------------------------------- 1 | module DB.Helpers where 2 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # CHANGELOG 2 | 3 | ## v0.0.1.0 – 4 | * Release 5 | -------------------------------------------------------------------------------- /assets/js/index.js: -------------------------------------------------------------------------------- 1 | "use strict"; 2 | import "../css/style.css"; 3 | -------------------------------------------------------------------------------- /app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Server 4 | 5 | main :: IO () 6 | main = appMain 7 | -------------------------------------------------------------------------------- /assets/images/hackage.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskellfoundation/matchmaker/HEAD/assets/images/hackage.png -------------------------------------------------------------------------------- /resources/matchmaker-frontpage.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskellfoundation/matchmaker/HEAD/resources/matchmaker-frontpage.png -------------------------------------------------------------------------------- /src/DB.hs: -------------------------------------------------------------------------------- 1 | module DB where 2 | 3 | import Database.PostgreSQL.Transact (DBT) 4 | 5 | class HasDB m where 6 | runDB :: DBT IO a -> m a 7 | -------------------------------------------------------------------------------- /.sosrc: -------------------------------------------------------------------------------- 1 | - pattern: src/(.*)\.hs 2 | commands: 3 | - cabal build -j10 4 | - cabal run matchmaker 5 | 6 | - pattern: test/(.*)\.hs 7 | commands: 8 | - cabal test 9 | -------------------------------------------------------------------------------- /src/Web/Sessions/Types.hs: -------------------------------------------------------------------------------- 1 | module Web.Sessions.Types where 2 | 3 | newtype UserAssigns = UserAssigns {getUserAssigns :: HashMap Text Text} 4 | deriving newtype (Show, Eq) 5 | -------------------------------------------------------------------------------- /.github/ISSUE_TEMPLATE.md: -------------------------------------------------------------------------------- 1 | Hi! 👋 Thank you for opening a ticket! 2 | 3 | Describe what you were trying to get done. 4 | Tell us what happened, what went wrong, and what you expected to happen. 5 | -------------------------------------------------------------------------------- /assets/tailwind.config.js: -------------------------------------------------------------------------------- 1 | module.exports = { 2 | purge: [], 3 | darkMode: false, // or 'media' or 'class' 4 | theme: { 5 | extend: {}, 6 | }, 7 | variants: { 8 | extend: {}, 9 | }, 10 | plugins: [], 11 | } 12 | -------------------------------------------------------------------------------- /migrations/20210423115240_organisations.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE IF NOT EXISTS organisations ( 2 | organisation_id uuid PRIMARY KEY, 3 | organisation_name TEXT NOT NULL, 4 | created_at TIMESTAMPTZ NOT NULL, 5 | updated_at TIMESTAMPTZ NOT NULL 6 | ); 7 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: ./ 2 | 3 | with-compiler: ghc-8.10.4 4 | tests: True 5 | 6 | index-state: 2021-09-06T17:46:21Z 7 | 8 | source-repository-package 9 | type: git 10 | location: https://github.com/tchoutri/pg-entity 11 | tag: 9561504be980735b133f14c9672a6f21503e060f 12 | -------------------------------------------------------------------------------- /test/DB/SpecHelpers.hs: -------------------------------------------------------------------------------- 1 | module DB.SpecHelpers where 2 | 3 | import Database.PostgreSQL.Simple (Connection) 4 | import Database.PostgreSQL.Simple.Migration 5 | 6 | migrate :: Connection -> IO () 7 | migrate conn = void $ runMigrations False conn [MigrationInitialization, MigrationDirectory "./migrations"] 8 | -------------------------------------------------------------------------------- /migrations/20210423114034_users.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE IF NOT EXISTS users ( 2 | user_id uuid PRIMARY KEY, 3 | username TEXT NOT NULL, 4 | email TEXT NOT NULL UNIQUE, 5 | display_name TEXT NOT NULL, 6 | password TEXT NOT NULL, 7 | created_at TIMESTAMPTZ NOT NULL, 8 | updated_at TIMESTAMPTZ NOT NULL 9 | ); 10 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.stack-work/ 2 | deployments/prod.sh 3 | Session.vim 4 | .envrc 5 | environment.local.sh 6 | .hie 7 | /static/* 8 | assets/node_modules 9 | dist-newstyle 10 | < 11 | & 12 | .hspec-failures 13 | src/Templates/Layout/layout.html 14 | ghcid.text 15 | /**/ghcid.text 16 | client_session_key.aes 17 | _database/ 18 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | # http://editorconfig.org 2 | 3 | root = true 4 | 5 | [*] 6 | indent_style = space 7 | indent_size = 2 8 | trim_trailing_whitespace = true 9 | insert_final_newline = true 10 | charset = utf-8 11 | end_of_line = lf 12 | 13 | [LICENSE] 14 | insert_final_newline = false 15 | 16 | [Makefile] 17 | indent_style = tab 18 | -------------------------------------------------------------------------------- /src/Handler/Signup.hs: -------------------------------------------------------------------------------- 1 | module Handler.Signup where 2 | 3 | import ImportYesod 4 | import Templates (render) 5 | import Templates.Helpers (emptyAssigns, moduleName) 6 | import Templates.Types (TemplateName (TemplateName)) 7 | 8 | getSignupR :: Handler Html 9 | getSignupR = render $$(moduleName) (TemplateName "signup") emptyAssigns 10 | -------------------------------------------------------------------------------- /src/Handler/Login.hs: -------------------------------------------------------------------------------- 1 | module Handler.Login where 2 | 3 | import ImportYesod 4 | import Templates (render) 5 | import Templates.Helpers (emptyAssigns, moduleName) 6 | import Templates.Types (TemplateName (TemplateName)) 7 | 8 | getLoginR :: Handler Html 9 | getLoginR = 10 | render $$(moduleName) (TemplateName "login") emptyAssigns 11 | 12 | 13 | -------------------------------------------------------------------------------- /.github/workflows/stylish-haskell-runner.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -eux 4 | 5 | git add . 6 | 7 | stylish-haskell -c .stylish-haskell.yaml -r src test app -i 8 | 9 | git status 10 | 11 | set +e 12 | git diff --exit-code 13 | diff_code=$? 14 | 15 | if [ $diff_code -ne 0 ] 16 | then 17 | echo "Test formatting failed" 18 | exit 1 19 | fi 20 | -------------------------------------------------------------------------------- /assets/webpack/postcss.config.js: -------------------------------------------------------------------------------- 1 | module.exports = { 2 | plugins: [ 3 | require("postcss-import"), 4 | require("postcss-flexbugs-fixes"), 5 | require("postcss-preset-env")({ 6 | autoprefixer: { 7 | flexbox: "no-2009" 8 | }, 9 | stage: 3 10 | }), 11 | require("tailwindcss"), 12 | require("autoprefixer") 13 | ] 14 | } 15 | -------------------------------------------------------------------------------- /.github/workflows/hlint-runner.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | set -eux 4 | 5 | git add . 6 | 7 | find app src test -name "*.hs" | xargs -P $(nproc) -I {} hlint --refactor-options="-i" --refactor {} 8 | 9 | git status 10 | 11 | set +e 12 | 13 | git diff --exit-code 14 | diff_code=$? 15 | 16 | if [ $diff_code -ne 0 ] 17 | then 18 | echo "Test Hlint failed" 19 | exit 1 20 | fi 21 | -------------------------------------------------------------------------------- /src/Templates/Types.hs: -------------------------------------------------------------------------------- 1 | module Templates.Types where 2 | 3 | -- | A wrapper around 'Text' for module names 4 | newtype ModuleName = ModuleName Text 5 | 6 | -- | A wrapper around 'Text' for template names 7 | newtype TemplateName = TemplateName Text 8 | 9 | -- | A wrapper around 'HashMap Text Text' for template assigns 10 | newtype TemplateAssigns = TemplateAssigns { getAssigns :: HashMap Text Text } 11 | -------------------------------------------------------------------------------- /src/Web/Helpers.hs: -------------------------------------------------------------------------------- 1 | module Web.Helpers where 2 | 3 | import Colourista.IO (cyanMessage) 4 | import Data.Time (getCurrentTime) 5 | import GHC.Stack (popCallStack) 6 | 7 | debug :: HasCallStack => (MonadIO m) => Text -> m () 8 | debug msg = do 9 | ts <- liftIO getCurrentTime 10 | liftIO $ cyanMessage $ show ts <> " [Debug] " <> msg 11 | liftIO $ cyanMessage $ toText $ prettyCallStack $ popCallStack callStack 12 | -------------------------------------------------------------------------------- /migrations/20210423181549_contributor_calls.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE IF NOT EXISTS contributor_calls ( 2 | contributor_call_id uuid NOT NULL, 3 | repository_id UUID NOT NULL, 4 | title TEXT NOT NULL, 5 | description TEXT NOT NULL, 6 | created_at TIMESTAMPTZ NOT NULL, 7 | updated_at TIMESTAMPTZ NOT NULL, 8 | CONSTRAINT contributor_calls_fk0 FOREIGN KEY ("repository_id") 9 | REFERENCES "repositories"("repository_id") 10 | ); 11 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec 4 | 5 | import qualified DB.OrganisationSpec as OrganisationSpec 6 | import qualified DB.UserSpec as UserSpec 7 | import qualified Web.AccountCreationSpec as AccountCreationSpec 8 | -- import qualified RepositorySpec as RepositorySpec 9 | 10 | main :: IO () 11 | main = hspec spec 12 | 13 | spec :: Spec 14 | spec = do 15 | UserSpec.spec 16 | OrganisationSpec.spec 17 | AccountCreationSpec.spec 18 | -------------------------------------------------------------------------------- /assets/css/style.css: -------------------------------------------------------------------------------- 1 | @import "tailwindcss/base"; 2 | @import "tailwindcss/components"; 3 | @import "tailwindcss/utilities"; 4 | 5 | @media (max-width:736px) { 6 | div.optional { 7 | display: none; 8 | } 9 | } 10 | 11 | .flash-alert-error { 12 | position: absolute; 13 | right: 2rem; 14 | min-width: 11%; 15 | margin-top: 1rem; 16 | } 17 | 18 | .flash-alert-info { 19 | position: absolute; 20 | right: 2rem; 21 | min-width: 11%; 22 | margin-top: 1rem; 23 | } 24 | -------------------------------------------------------------------------------- /src/Web/Middleware.hs: -------------------------------------------------------------------------------- 1 | module Web.Middleware where 2 | 3 | import Network.HTTP.Types (status200) 4 | import Network.Wai (Middleware, Request (..), pathInfo, responseLBS) 5 | 6 | heartbeat :: Middleware 7 | heartbeat app req sendResponse = app req $ \res -> 8 | if method `elem` ["GET", "HEAD"] && path == ["heartbeat"] 9 | then sendResponse $ responseLBS status200 [("Content-Type", "text/plain")] "OK." 10 | else sendResponse res 11 | where 12 | method = requestMethod req 13 | path = pathInfo req 14 | -------------------------------------------------------------------------------- /src/Web/Router.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -Wno-unused-imports #-} 2 | module Web.Router (router) where 3 | 4 | import Prelude hiding (get) 5 | import Rowdy.Yesod 6 | import Yesod.Core 7 | import Yesod.Routes.TH.Types (ResourceTree) 8 | 9 | 10 | router :: [ResourceTree String] 11 | router = toYesod $ do 12 | get "HomeR" 13 | "login" // do 14 | get "LoginR" 15 | "signin" // post "LoginSigninR" 16 | 17 | "signup" // get "SignupR" 18 | "account" // "create" // post "AccountCreateR" 19 | "user" // get "UserR" 20 | -------------------------------------------------------------------------------- /migrations/20210423115352_user_organisation.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE IF NOT EXISTS user_organisation ( 2 | user_organisation_id uuid PRIMARY KEY, 3 | user_id uuid NOT NULL, 4 | organisation_id uuid NOT NULL, 5 | is_admin bool NOT NULL, 6 | CONSTRAINT user_organisation_fk0 FOREIGN KEY ("user_id") 7 | REFERENCES "users"("user_id"), 8 | CONSTRAINT user_organisation_fk1 FOREIGN KEY ("organisation_id") 9 | REFERENCES "organisations"("organisation_id") 10 | ); 11 | 12 | CREATE INDEX user_organisation_admin ON user_organisation (is_admin); 13 | -------------------------------------------------------------------------------- /environment.sh: -------------------------------------------------------------------------------- 1 | export MATCHMAKER_PORT="8008" 2 | export MATCHMAKER_LOG_LEVEL="debug" 3 | 4 | export DB_HOST="localhost" 5 | export DB_PORT="5432" 6 | export DB_USER="postgres" 7 | export DB_PASSWORD="postgres" 8 | export DB_DATABASE="matchmaker_dev" 9 | export DB_POOL_CONNECTIONS="10" 10 | export DB_SUB_POOLS="10" 11 | export DB_TIMEOUT="10" 12 | 13 | export PG_URI="postgresql://${DB_USER}:${DB_PASSWORD}@${DB_HOST}:${DB_PORT}/${DB_DATABASE}" 14 | export PG_CONNSTRING="host=${DB_HOST} dbname=${DB_DATABASE} user=${DB_USER} password=${DB_PASSWORD}" 15 | 16 | export NIXPKGS_ALLOW_BROKEN=1 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2021 The Haskell Foundation 2 | 3 | Licensed under the Apache License, Version 2.0 (the "License"); 4 | you may not use this file except in compliance with the License. 5 | You may obtain a copy of the License at 6 | 7 | http://www.apache.org/licenses/LICENSE-2.0 8 | 9 | Unless required by applicable law or agreed to in writing, software 10 | distributed under the License is distributed on an "AS IS" BASIS, 11 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12 | See the License for the specific language governing permissions and 13 | limitations under the License. 14 | -------------------------------------------------------------------------------- /src/Templates/Helpers.hs: -------------------------------------------------------------------------------- 1 | module Templates.Helpers where 2 | 3 | import qualified Data.HashMap.Strict as HM 4 | import qualified Data.Text as T 5 | import Language.Haskell.TH 6 | import Language.Haskell.TH.Syntax 7 | import qualified Relude.Unsafe as U 8 | 9 | import Templates.Types 10 | 11 | -- | Use this function in a View module so that the template name and location 12 | -- can be inferred from the name of the view 13 | moduleName :: Q (TExp ModuleName) 14 | moduleName = do 15 | name <- loc_module <$> qLocation 16 | [|| ModuleName $ U.last $ T.splitOn "." $ toText @String name ||] 17 | 18 | emptyAssigns :: TemplateAssigns 19 | emptyAssigns = TemplateAssigns HM.empty 20 | -------------------------------------------------------------------------------- /src/Web/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StrictData #-} 2 | module Web.Types 3 | ( DBError(..) 4 | , MatchmakerError(..) 5 | , WebError(..) 6 | ) where 7 | 8 | data MatchmakerError 9 | = DB DBError 10 | | Web WebError 11 | | TextError {-# UNPACK #-}Text 12 | deriving stock (Eq, Generic, Show) 13 | 14 | data WebError 15 | = LoginFailure 16 | deriving stock (Eq, Generic, Show) 17 | 18 | instance Exception WebError 19 | 20 | data DBError 21 | = ConstraintError {-# UNPACK #-}Text 22 | | NotFound 23 | | TooManyResults 24 | | InsertionError 25 | | DeserialisationError {-# UNPACK #-}Text 26 | deriving stock (Eq, Generic, Show) 27 | 28 | instance Exception DBError 29 | -------------------------------------------------------------------------------- /migrations/20210423181548_repositories.sql: -------------------------------------------------------------------------------- 1 | CREATE TABLE IF NOT EXISTS repositories ( 2 | repository_id uuid PRIMARY KEY, 3 | organisation_id uuid NOT NULL, 4 | repository_name TEXT NOT NULL, 5 | repository_description TEXT NOT NULL, 6 | repository_url TEXT NOT NULL, 7 | repository_homepage TEXT, 8 | created_at TIMESTAMPTZ NOT NULL, 9 | updated_at TIMESTAMPTZ NOT NULL, 10 | CONSTRAINT repositories_fk0 FOREIGN KEY ("organisation_id") 11 | REFERENCES "organisations"("organisation_id") 12 | ); 13 | 14 | CREATE INDEX repository_name_index ON repositories(repository_name); 15 | CREATE UNIQUE INDEX repo_name_org ON repositories (repository_name, organisation_id); 16 | -------------------------------------------------------------------------------- /src/Handler/User.hs: -------------------------------------------------------------------------------- 1 | module Handler.User where 2 | 3 | import ImportYesod 4 | 5 | import Data.HashMap.Strict as HashMap 6 | 7 | import DB.User 8 | import Templates (render) 9 | import Templates.Helpers (moduleName) 10 | import Templates.Types 11 | import Web.Sessions 12 | 13 | getUserR :: Handler Html 14 | getUserR = do 15 | mUserId <- getUserIdFromSession 16 | assigns <- case mUserId of 17 | Nothing -> pure $ TemplateAssigns HashMap.empty 18 | Just uId -> do 19 | (Just User{..}) <- runDB $ getUserById uId 20 | pure $ TemplateAssigns $ HashMap.fromList [("username", username)] 21 | render $$(moduleName) (TemplateName "show") assigns 22 | -------------------------------------------------------------------------------- /src/Web/FlashAlerts.hs: -------------------------------------------------------------------------------- 1 | module Web.FlashAlerts where 2 | 3 | import ImportYesod 4 | import Templates.Partials.FlashAlerts (errorTemplate, infoTemplate) 5 | import Web.Sessions (popAssign, putAssign) 6 | 7 | getFlashes :: Handler Text 8 | getFlashes = do 9 | maybeError <- getError 10 | maybeInfo <- getInfo 11 | traceShowM maybeInfo 12 | let err = maybe "" errorTemplate maybeError 13 | let info = maybe "" infoTemplate maybeInfo 14 | pure $ err <> info 15 | 16 | putInfo :: Text -> Handler () 17 | putInfo msg = putAssign "flash_alert_info" msg 18 | 19 | putError :: Text -> Handler () 20 | putError msg = putAssign "flash_alert_error" msg 21 | 22 | getInfo :: Handler (Maybe Text) 23 | getInfo = popAssign "flash_alert_info" 24 | 25 | getError :: Handler (Maybe Text) 26 | getError = popAssign "flash_alert_error" 27 | -------------------------------------------------------------------------------- /src/Handler/Home.hs: -------------------------------------------------------------------------------- 1 | module Handler.Home where 2 | 3 | import DB.User (User (..), UserId (..), getUserById) 4 | import qualified Data.HashMap.Strict as HM 5 | import Data.UUID (fromText) 6 | import ImportYesod 7 | import Templates (render) 8 | import Templates.Helpers (moduleName) 9 | import Templates.Types (TemplateAssigns (TemplateAssigns), 10 | TemplateName (TemplateName)) 11 | import Web.Sessions (readAssign) 12 | 13 | getHomeR :: Handler Html 14 | getHomeR = do 15 | mUserId <- readAssign "user_id" $ fmap UserId . fromText 16 | assigns <- 17 | maybe 18 | (pure $ TemplateAssigns HM.empty) 19 | (\uId -> do 20 | (Just user) <- runDB $ getUserById uId 21 | pure $ TemplateAssigns $ HM.fromList [("displayName", displayName user)] 22 | ) 23 | mUserId 24 | render $$(moduleName) (TemplateName "index") assigns 25 | 26 | 27 | -------------------------------------------------------------------------------- /src/ImportYesod.hs: -------------------------------------------------------------------------------- 1 | -- | This module is a convenience module, it re-exports the most common modules 2 | -- required to write a handler: 3 | -- - 'DB' exports the @HasDB@ class, which allows you to use 'runDB' 4 | -- - 'Foundation' exports the actual @Handler@ type as well as the @Foundation@ type 5 | -- - 'Yesod.Core' provides the majority of the yesod functionality you might require 6 | -- i.e. the @Html@ ContentType and 'redirect' 7 | -- 8 | -- A word of caution: It behooves us to keep the re-exports here to a minimum. Choke points 9 | -- like this in the module graph can really explode compilation times, and the more modules 10 | -- that get added here, the harder it becomes to manage module cycles. 11 | module ImportYesod 12 | ( 13 | module DB, 14 | module Foundation, 15 | module Yesod.Core, 16 | ) where 17 | 18 | import DB 19 | import Foundation 20 | import Yesod.Core 21 | -------------------------------------------------------------------------------- /assets/webpack/plugins/bundle-hash-plugin.js: -------------------------------------------------------------------------------- 1 | const path = require("path"); 2 | const _ = require("lodash"); 3 | const fs = require('fs'); 4 | 5 | const pluginName = "BundleHashPlugin"; 6 | 7 | class BundleHashPlugin { 8 | constructor(options) { 9 | this.options = options; 10 | } 11 | 12 | apply(compiler) { 13 | compiler.hooks.compilation.tap(pluginName, (compilation, compilationParams) => { 14 | console.log(JSON.stringify({compilation})); 15 | // const assets = compilation.getAssets(); 16 | // console.log({assets}) 17 | // const bundle = _.head(_.filter(assets, (o) => _.endsWith(o.name, ".js"))) 18 | console.log(`Writing the bundle name to ${this.options.publicPath}/bundleName.txt`); 19 | fs.writeFileSync(`${this.options.publicPath}/bundleName.txt`, bundle.name, "utf8"); 20 | }); 21 | } 22 | } 23 | 24 | module.exports = { BundleHashPlugin }; 25 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let pkgs = import (builtins.fetchTarball { 2 | # master on 2021-08-01 3 | url = "https://github.com/NixOS/nixpkgs/archive/9fc2cddf24ad1819f17174cbae47789294ea6dc4.tar.gz"; 4 | sha256 = "058l6ry119mkg7pwmm7z4rl1721w0zigklskq48xb5lmgig4l332"; 5 | }) { }; 6 | in with pkgs; 7 | mkShell { 8 | shellHook = '' 9 | source environment.sh 10 | ''; 11 | buildInputs = [ 12 | # Haskell Deps 13 | haskell.compiler.ghc8104 14 | cabal-install 15 | ghcid 16 | hlint 17 | haskellPackages.apply-refact 18 | stylish-haskell 19 | git 20 | 21 | # Frontend Deps 22 | yarn 23 | nodejs-14_x 24 | 25 | # DB Deps 26 | postgresql_12 27 | gmp 28 | zlib 29 | glibcLocales 30 | haskellPackages.postgresql-simple-migration 31 | 32 | # Extra 33 | direnv 34 | ]; 35 | } 36 | -------------------------------------------------------------------------------- /test/Web/AccountCreationSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | 3 | module Web.AccountCreationSpec where 4 | 5 | import Test.Hspec (Spec) 6 | import Test.Hspec.DB (describeDB, itDB) 7 | import Test.Hspec.Expectations.Lifted (expectationFailure) 8 | 9 | import DB.Organisation (getOrganisationByName) 10 | import DB.SpecHelpers (migrate) 11 | import Handler.Account.Create (postAccountCreate) 12 | 13 | postData1 :: [(Text, Text)] 14 | postData1 = 15 | [ ("username" , "wildcat") 16 | , ("email" , "force_captain@horde.io") 17 | , ("displayname", "Catra") 18 | , ("password" , "adorauwu") 19 | ] 20 | 21 | spec :: Spec 22 | spec = describeDB migrate "org" $ do 23 | itDB "Users have a default organisation" $ do 24 | let orgName = "default_org_for_wildcat" 25 | runExceptT (postAccountCreate postData1) >>= \case 26 | Left errors -> expectationFailure $ "Validation error(s): " <> show errors 27 | Right _ -> pure () 28 | whenNothingM_ (getOrganisationByName orgName) 29 | $ expectationFailure "no default org created or name formatting changed" 30 | -------------------------------------------------------------------------------- /assets/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "frontend", 3 | "private": true, 4 | "scripts": { 5 | "watch-css": "yarn postcss -w css/style.css -o ../static/style.css", 6 | "build": "webpack --config webpack/webpack.config.js", 7 | "watch": "webpack -w --config webpack/webpack.config.js" 8 | }, 9 | "dependencies": { 10 | "dayjs": "^1.10.4", 11 | "postcss-flexbugs-fixes": "^5.0.2", 12 | "postcss-import": "^14.0.0", 13 | "postcss-preset-env": "^6.7.0", 14 | "tailwindcss": "^2.0.2" 15 | }, 16 | "devDependencies": { 17 | "autoprefixer": "^10.2.1", 18 | "copy-webpack-plugin": "^8.1.1", 19 | "css-loader": "^5.1.1", 20 | "html-webpack-plugin": "^5.3.1", 21 | "loader-utils": "^2.0.0", 22 | "lodash": "^4.17.21", 23 | "mini-css-extract-plugin": "^1.3.9", 24 | "postcss": "^8.2.4", 25 | "postcss-cli": "^8.3.1", 26 | "postcss-loader": "^5.1.0", 27 | "postcss-modules": "^4.0.0", 28 | "style-loader": "^2.0.0", 29 | "webpack": "^5.24.4", 30 | "webpack-cli": "^4.5.0", 31 | "webpack-manifest-plugin": "^3.0.0" 32 | } 33 | } 34 | -------------------------------------------------------------------------------- /src/Web/Form.hs: -------------------------------------------------------------------------------- 1 | module Web.Form ( 2 | module Web.Form, 3 | module Web.Form.Types, 4 | ) where 5 | 6 | import Data.Map hiding (fold, toList) 7 | import ImportYesod 8 | import Templates.Partials.FlashAlerts 9 | import Web.FlashAlerts 10 | import Web.Form.Types 11 | 12 | fieldError :: e -> FormValidation e a 13 | fieldError err = FieldErrors $ err :| [] 14 | 15 | lookupFormFieldTextError :: Text -> Map Text Text -> FormValidation Text Text 16 | lookupFormFieldTextError k m = lookupFormField id k m 17 | 18 | lookupFormField :: (Text -> e) -> Text -> Map Text Text -> FormValidation e Text 19 | lookupFormField err k m = 20 | case lookup k m of 21 | Nothing -> fieldError . err $ k 22 | Just v -> Result v 23 | 24 | lookupOptionalFormField :: Text -> Map Text Text -> FormValidation Text (Maybe Text) 25 | lookupOptionalFormField k m = Result $ lookup k m 26 | 27 | handleMissingFields :: Route Foundation -> FormValidation Text a -> Handler a 28 | handleMissingFields route (FieldErrors fields) = do 29 | putError . errorTemplate . fold . intersperse ", " $ toList fields 30 | redirect route 31 | handleMissingFields _ (Result res) = pure res 32 | -------------------------------------------------------------------------------- /src/Templates/Partials/FlashAlerts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | module Templates.Partials.FlashAlerts where 3 | 4 | import Data.String.Interpolate 5 | 6 | infoTemplate :: Text -> Text 7 | infoTemplate msg = [i| 8 | 14 | |] 15 | 16 | errorTemplate :: Text -> Text 17 | errorTemplate msg = [i| 18 | 24 | |] 25 | -------------------------------------------------------------------------------- /src/Templates/Error/500.html: -------------------------------------------------------------------------------- 1 | {% extends '../Layout/layout.html' %} 2 | {% block content %} 3 |
4 |
5 |
6 |
7 |

404

8 |

oops! Page not found

9 |

Oops! The page you are looking for does not exist. It might have been moved or deleted.

10 | 13 | 16 |
17 |
18 |
19 |
20 | {% endblocl %} 21 | -------------------------------------------------------------------------------- /src/Handler.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | -- | This module is important, it is where we import all of our handler functions and make 3 | -- them available to Yesod. You should get a type error when you add a route to the router 4 | -- and don't add a corresponding handler function here, but I figure this comment might be 5 | -- useful since this is one of the more magical pieces of Yesod. 6 | module Handler where 7 | 8 | import Foundation 9 | import Yesod.Core (mkYesodDispatch) 10 | 11 | -- Handlers 12 | import Handler.Account.Create 13 | import Handler.Home 14 | import Handler.Login 15 | import Handler.Login.Signin 16 | import Handler.Signup 17 | import Handler.User 18 | 19 | -- | This is the second half of the router template haskell. This is called the "dispatch" and 20 | -- 'resourcesFoundation' is what takes all of our handler functions in scope and makes them available 21 | -- to Yesod. 22 | -- Note: unfortunately mkYesodDispatch introduces an instance for Handler, but Handler is 23 | -- "defined" (by template haskell) in Foundation.hs. Therefore we have to turn off warning 24 | -- on orphan instances. This file structure is nice, though, because it prevents import 25 | -- cycles and allows us to import all our handler functions in one file. 26 | mkYesodDispatch "Foundation" resourcesFoundation 27 | -------------------------------------------------------------------------------- /src/Web/Form/Types.hs: -------------------------------------------------------------------------------- 1 | module Web.Form.Types where 2 | 3 | import Foundation (Handler) 4 | 5 | data FormValidation e a = FieldErrors (NonEmpty e) 6 | | Result a 7 | 8 | instance Functor (FormValidation e) where 9 | fmap _ (FieldErrors fs) = FieldErrors fs 10 | fmap f (Result a)= Result $ f a 11 | 12 | instance Applicative (FormValidation e) where 13 | pure = Result 14 | (<*>) (FieldErrors fs) (FieldErrors gs) = FieldErrors $ fs <> gs 15 | (<*>) (FieldErrors fs) _ = FieldErrors fs 16 | (<*>) _ (FieldErrors fs) = FieldErrors fs 17 | (<*>) (Result f) (Result a) = Result $ f a 18 | 19 | instance Monad (FormValidation e) where 20 | return = pure 21 | (>>=) (Result a) f = f a 22 | (>>=) (FieldErrors f) _ = FieldErrors f 23 | 24 | instance Bifunctor FormValidation where 25 | bimap f _ (FieldErrors e) = FieldErrors $ f <$> e 26 | bimap _ g (Result r) = Result $ g r 27 | 28 | instance Foldable (FormValidation e) where 29 | foldMap _ (FieldErrors _) = mempty 30 | foldMap f (Result r) = f r 31 | 32 | instance Traversable (FormValidation e) where 33 | sequenceA (FieldErrors e) = pure (FieldErrors e) 34 | sequenceA (Result fa) = fmap Result fa 35 | 36 | class ErrorToAssign e where 37 | putErrorAssign :: e -> Handler () 38 | 39 | handleFormErrors :: ErrorToAssign e => NonEmpty e -> Handler () 40 | handleFormErrors = mapM_ putErrorAssign 41 | -------------------------------------------------------------------------------- /test/DB/UserSpec.hs: -------------------------------------------------------------------------------- 1 | module DB.UserSpec where 2 | 3 | import Data.Password.Argon2 4 | import Relude.Unsafe (read) 5 | import Test.Hspec (Spec) 6 | import Test.Hspec.DB (describeDB, itDB) 7 | import Test.Hspec.Expectations.Lifted (shouldReturn) 8 | 9 | import DB.SpecHelpers (migrate) 10 | import DB.User 11 | 12 | user1 :: User 13 | user1 = 14 | let userId = UserId (read "4e511d7a-a464-11eb-b30b-5405db82c3cd") 15 | username = "pmpc" 16 | email = "pmpc@example.com" 17 | displayName = "Plonk McPlonkface" 18 | password = PasswordHash "foobar2000" 19 | createdAt = read "2021-04-23 10:00:00 UTC" 20 | updatedAt = read "2021-04-23 10:00:00 UTC" 21 | in User{..} 22 | 23 | user2 :: User 24 | user2 = 25 | let userId = UserId (read "44495a98-a475-11eb-94f3-5405db82c3cd") 26 | username = "blue_devil" 27 | email = "princess_jack@example.com" 28 | displayName = "Princess Jack Moonshine" 29 | password = PasswordHash "DRINK!" 30 | createdAt = read "2021-04-23 14:00:00 UTC" 31 | updatedAt = read "2021-04-23 14:30:00 UTC" 32 | in User{..} 33 | 34 | 35 | spec :: Spec 36 | spec = describeDB migrate "users" $ do 37 | itDB "Insert user and fetch it" $ do 38 | insertUser user1 39 | getUserById (userId user1) 40 | `shouldReturn` Just user1 41 | itDB "Insert user and fetch it by email" $ do 42 | insertUser user2 43 | getUserByEmail (email user2) 44 | `shouldReturn` Just user2 45 | -------------------------------------------------------------------------------- /.github/workflows/install-nix.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | set -euo pipefail 3 | 4 | if type -p nix &>/dev/null ; then 5 | echo "Aborting: Nix is already installed at $(type -p nix)" 6 | exit 7 | fi 8 | 9 | # Configure Nix 10 | add_config() { 11 | echo "$1" | sudo tee -a /tmp/nix.conf >/dev/null 12 | } 13 | # Set jobs to number of cores 14 | add_config "max-jobs = auto" 15 | # Allow binary caches for user 16 | add_config "trusted-users = root $USER" 17 | 18 | # Nix installer flags 19 | installer_options=( 20 | --daemon 21 | --daemon-user-count 4 22 | --no-channel-add 23 | --darwin-use-unencrypted-nix-store-volume 24 | --nix-extra-conf-file /tmp/nix.conf 25 | ) 26 | 27 | echo "installer options: ${installer_options[@]}" 28 | # On self-hosted runners we don't need to install more than once 29 | if [[ ! -d /nix/store ]] 30 | then 31 | sh <(curl --retry 5 --retry-connrefused -L "https://nixos.org/nix/install") "${installer_options[@]}" 32 | fi 33 | 34 | if [[ $OSTYPE =~ darwin ]]; then 35 | # Disable spotlight indexing of /nix to speed up performance 36 | sudo mdutil -i off /nix 37 | 38 | # macOS needs certificates hints 39 | cert_file=/nix/var/nix/profiles/default/etc/ssl/certs/ca-bundle.crt 40 | echo "NIX_SSL_CERT_FILE=$cert_file" >> "$GITHUB_ENV" 41 | export NIX_SSL_CERT_FILE=$cert_file 42 | sudo launchctl setenv NIX_SSL_CERT_FILE "$cert_file" 43 | fi 44 | 45 | # Set paths 46 | 47 | # if [[ $INPUT_NIX_PATH != "" ]]; then 48 | # echo "NIX_PATH=${INPUT_NIX_PATH}" >> "$GITHUB_ENV" 49 | # fi 50 | -------------------------------------------------------------------------------- /src/Handler/Login/Signin.hs: -------------------------------------------------------------------------------- 1 | module Handler.Login.Signin where 2 | 3 | import Data.Password.Argon2 4 | 5 | import DB.User 6 | import qualified Data.Map as M 7 | import ImportYesod 8 | import Templates.Partials.FlashAlerts 9 | import Web.FlashAlerts 10 | import Web.Form 11 | import Web.Sessions (markAuthenticated) 12 | 13 | postLoginSigninR :: Handler () 14 | postLoginSigninR = do 15 | postParams <- getPostParams 16 | SigninForm{..} <- handleMissingFields LoginSigninR $ parseSigninFormParams postParams 17 | mUser <- runDB $ getUserByEmail signinFormEmail 18 | case mUser of 19 | Just user -> validateLogin signinFormPassword user 20 | Nothing -> do 21 | putError $ errorTemplate "Login failure" 22 | redirect LoginR 23 | 24 | data SigninForm = 25 | SigninForm 26 | { signinFormEmail :: Text 27 | , signinFormPassword :: Password 28 | } 29 | 30 | parseSigninFormParams :: [(Text, Text)] -> FormValidation Text SigninForm 31 | parseSigninFormParams params = 32 | let paramMap = M.fromList params 33 | mPassword = mkPassword <$> lookupFormFieldTextError "password" paramMap 34 | mEmail = lookupFormFieldTextError "email" paramMap 35 | in liftA2 SigninForm mEmail mPassword 36 | 37 | validateLogin :: Password -> User -> Handler () 38 | validateLogin loginPassword user = do 39 | if validatePassword loginPassword (password user) 40 | then do 41 | markAuthenticated (userId user) 42 | putInfo $ infoTemplate "Logged-in" 43 | redirect HomeR 44 | else do 45 | putError $ errorTemplate "Login failure" 46 | redirect LoginR 47 | -------------------------------------------------------------------------------- /src/DB/ContributorCall.hs: -------------------------------------------------------------------------------- 1 | module DB.ContributorCall where 2 | 3 | import Data.Aeson (FromJSON, ToJSON) 4 | import Data.Time (UTCTime) 5 | import Data.UUID (UUID) 6 | import Database.PostgreSQL.Entity 7 | import Database.PostgreSQL.Simple (FromRow, Only (Only), ToRow) 8 | import Database.PostgreSQL.Simple.FromField (FromField) 9 | import Database.PostgreSQL.Simple.ToField (ToField) 10 | import Database.PostgreSQL.Transact (DBT) 11 | 12 | import DB.Repository (RepositoryId) 13 | import Database.PostgreSQL.Entity.Types 14 | 15 | newtype ContributorCallId 16 | = ContributorCallId { getContributorCallId :: UUID } 17 | deriving stock (Eq, Generic) 18 | deriving newtype (FromField, FromJSON, Show, ToField, ToJSON) 19 | 20 | data ContributorCall 21 | = ContributorCall { contributorCallId :: ContributorCallId 22 | , repositoryId :: RepositoryId 23 | , title :: Text 24 | , description :: Text 25 | , createdAt :: UTCTime 26 | , updatedAt :: UTCTime 27 | } 28 | deriving stock (Eq, Generic, Show) 29 | deriving anyclass (FromRow, ToRow) 30 | deriving (Entity) 31 | via (GenericEntity '[TableName "contributor_calls"] ContributorCall) 32 | 33 | insertContributorCall :: ContributorCall -> DBT IO () 34 | insertContributorCall cc = insert @ContributorCall cc 35 | 36 | getContributorCall :: ContributorCallId -> DBT IO (Maybe ContributorCall) 37 | getContributorCall ccId = selectById @ContributorCall (Only ccId) 38 | 39 | deleteContributorCall :: ContributorCallId -> DBT IO () 40 | deleteContributorCall ccId = delete @ContributorCall (Only ccId) 41 | -------------------------------------------------------------------------------- /assets/webpack/webpack.config.js: -------------------------------------------------------------------------------- 1 | "use strict"; 2 | 3 | const path = require("path"); 4 | const { WebpackManifestPlugin } = require("webpack-manifest-plugin"); 5 | const HtmlWebpackPlugin = require("html-webpack-plugin") 6 | const CopyPlugin = require("copy-webpack-plugin"); 7 | 8 | const postCss = { 9 | loader: "postcss-loader", 10 | options: { 11 | postcssOptions: require("./postcss.config"), 12 | }, 13 | }; 14 | 15 | const cssLoader = { 16 | loader: "css-loader", 17 | options: { 18 | importLoaders: 1, 19 | }, 20 | }; 21 | 22 | const publicPath = path.resolve(__dirname, "../../static/"); 23 | 24 | module.exports = { 25 | entry: "./js/index.js", 26 | devtool: "source-map", 27 | mode: "development", 28 | output: { 29 | filename: "[name]-bundle.[contenthash].js", 30 | path: publicPath, 31 | clean: true, 32 | }, 33 | module: { 34 | rules: [ 35 | { 36 | test: /\.js$/i, 37 | exclude: [/node_modules/] 38 | }, 39 | { 40 | test: /\.css$/i, 41 | use: ["style-loader", cssLoader, postCss], 42 | }, 43 | { 44 | test: /\.(png|svg|jpg|jpeg|gif)$/i, 45 | type: "asset/resource", 46 | generator: { 47 | filename: "${publicPath}/[name][ext]" 48 | } 49 | }, 50 | ], 51 | }, 52 | plugins: [ 53 | new HtmlWebpackPlugin({ 54 | filename: "../src/Templates/Layout/layout.html", 55 | template: "./layout.jinja.template", 56 | inject: false, 57 | }), 58 | new WebpackManifestPlugin({ 59 | writeToFileEmit: true, 60 | publicPath, 61 | }), 62 | new CopyPlugin({ 63 | patterns: [ 64 | { from: "images", to: publicPath }, 65 | ], 66 | }), 67 | ] 68 | }; 69 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Matchmaker [![CI-badge][CI-badge]][CI-url] ![simple-haskell][simple-haskell] 2 | 3 | 4 | 5 | ## Description 6 | 7 | *Matchmaker* is a project of the Haskell Foundation to help open-source maintainers and contributors find each-other, 8 | and provide a smoother experience for people wishing to invest themselves in the opens-source Haskell ecosystem. 9 | 10 | ## Prerequisites 11 | 12 | * PostgreSQL 12 or higher 13 | * GHC 8.10.4 14 | * Yarn 1.22 or higher 15 | 16 | *Note* 17 | There is a `shell.nix` file provided for convenience. However it is far from perfect. 18 | It will not manage a local installation of PostgreSQL for you. 19 | You should be able to work in a pure shell. If not, file a bug! 20 | The nix shell should source all environment variables when you enter it. 21 | 22 | The `Makefile` contains all the development-related scripts you'll need. Please 23 | refer to the output of `make help` for more information. 24 | 25 | ## Running Matchmaker 26 | 27 | ### Backend 28 | 29 | ```bash 30 | # Build `matchmaker` and its dependencies 31 | $ make deps 32 | $ make build 33 | 34 | # Initialize database configuration if you haven't already 35 | $ make db-init 36 | 37 | # Start the database 38 | $ make db-start 39 | 40 | # Run migrations against the running database (in another terminal) 41 | $ make db-setup 42 | 43 | # Start `matchmaker` 44 | $ make start 45 | ``` 46 | 47 | ### Frontend 48 | 49 | ```bash 50 | $ make assets-deps 51 | $ make assets-build # or assets-watch if you're working on CSS/JS 52 | ``` 53 | 54 | [simple-haskell]: https://img.shields.io/badge/Simple-Haskell-purple?style=flat-square 55 | [CI-badge]: https://img.shields.io/github/workflow/status/haskellfoundation/matchmaker/CI?style=flat-square 56 | [CI-url]: https://github.com/haskellfoundation/matchmaker/actions 57 | -------------------------------------------------------------------------------- /test/fixtures.sql: -------------------------------------------------------------------------------- 1 | -- You can load this file into the database by running: 2 | -- $ psql "$PG_URI" < test/fixtures.sql 3 | INSERT INTO "organisations" ("organisation_id", 4 | "organisation_name", 5 | "created_at", 6 | "updated_at") 7 | VALUES ('b63ad088-a474-11eb-9236-5405db82c3cd', 8 | 'ghchq', 9 | '2021-04-10 01:00:00Z', 10 | '2021-04-11 01:00:00Z' 11 | ); 12 | 13 | INSERT INTO "users" ("user_id", 14 | "username", 15 | "email", 16 | "display_name", 17 | "password", 18 | "created_at", 19 | "updated_at") 20 | VALUES ('44495a98-a475-11eb-94f3-5405db82c3cd', 21 | 'blue_devil', 22 | 'princess_jack@example.com', 23 | 'Princess Jack Moonshine', 24 | 'DRINK!', 25 | '2021-04-23 14:00:00Z', 26 | '2021-04-23 14:30:00Z' 27 | ); 28 | 29 | INSERT INTO "user_organisation" ("user_organisation_id", 30 | "user_id", 31 | "organisation_id", 32 | "is_admin") 33 | VALUES ('c798acb4-3446-48c2-a8ec-08799535c1e6', 34 | '44495a98-a475-11eb-94f3-5405db82c3cd', 35 | 'b63ad088-a474-11eb-9236-5405db82c3cd', 36 | false 37 | ); 38 | 39 | UPDATE "user_organisation" SET ("user_id", 40 | "organisation_id", 41 | "is_admin") = 42 | ROW('44495a98-a475-11eb-94f3-5405db82c3cd', 43 | 'b63ad088-a474-11eb-9236-5405db82c3cd', 44 | true) 45 | WHERE "user_organisation_id" = 'c798acb4-3446-48c2-a8ec-08799535c1e6'; 46 | -------------------------------------------------------------------------------- /src/Handler/Account/Create.hs: -------------------------------------------------------------------------------- 1 | module Handler.Account.Create where 2 | 3 | import Control.Monad.Except (throwError) 4 | import DB.Organisation 5 | import DB.User 6 | import Data.Time 7 | import Data.UUID.V4 (nextRandom) 8 | import Database.PostgreSQL.Transact (DBT) 9 | import ImportYesod 10 | import Model.UserModel 11 | import Web.Form 12 | import Web.Sessions 13 | 14 | postAccountCreateR :: Handler () 15 | postAccountCreateR = do 16 | postParams <- getPostParams 17 | result <- runDB $ runExceptT $ postAccountCreate postParams 18 | case result of 19 | Left errors -> do 20 | putAssign "form_error" "true" 21 | handleFormErrors errors 22 | redirect SignupR 23 | Right _ -> 24 | redirect HomeR 25 | 26 | postAccountCreate 27 | :: [(Text, Text)] 28 | -> ExceptT (NonEmpty NewUserValidationError) (DBT IO) () 29 | postAccountCreate postParams = do 30 | newUser <- liftIO $ validateNewUser postParams 31 | case newUser of 32 | FieldErrors errors -> throwError errors 33 | Result user@User{..} -> do 34 | orgId <- liftIO $ OrganisationId <$> nextRandom 35 | userOrgId <- liftIO $ UserOrganisationId <$> nextRandom 36 | timestamp <- liftIO getCurrentTime 37 | let org = newOrganisationFor orgId timestamp user 38 | lift $ insertUser user 39 | *> insertOrganisation org 40 | *> attachUser userId orgId userOrgId 41 | where 42 | newOrganisationFor :: OrganisationId -> UTCTime -> User -> Organisation 43 | newOrganisationFor organisationId createdAt user = 44 | Organisation 45 | { organisationId 46 | , organisationName = newOrgNameFrom user 47 | , createdAt 48 | , updatedAt = createdAt 49 | } 50 | 51 | newOrgNameFrom :: User -> Text 52 | newOrgNameFrom User{..} = userOrgNamePrefix <> username 53 | 54 | userOrgNamePrefix :: Text 55 | userOrgNamePrefix = "default_org_for_" 56 | -------------------------------------------------------------------------------- /src/DB/Repository.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | module DB.Repository where 3 | 4 | import Data.Aeson (FromJSON, ToJSON) 5 | import Data.Time (UTCTime) 6 | import Data.UUID (UUID) 7 | import Data.Vector (Vector) 8 | import Database.PostgreSQL.Entity 9 | import Database.PostgreSQL.Simple (FromRow, Only (Only), ToRow) 10 | import Database.PostgreSQL.Simple.FromField (FromField) 11 | import Database.PostgreSQL.Simple.ToField (ToField) 12 | import Database.PostgreSQL.Transact (DBT) 13 | 14 | import DB.Organisation (OrganisationId (..)) 15 | import Database.PostgreSQL.Entity.Types 16 | 17 | newtype RepositoryId 18 | = RepositoryId { getRepositoryId :: UUID } 19 | deriving stock (Eq, Generic) 20 | deriving newtype (FromField, FromJSON, Show, ToField, ToJSON) 21 | 22 | data Repository 23 | = Repository { repositoryId :: RepositoryId 24 | , organisationId :: OrganisationId 25 | , repositoryName :: Text 26 | , repositoryDescription :: Text 27 | , repositoryURL :: Text 28 | , repositoryHomepage :: Maybe Text 29 | , createdAt :: UTCTime 30 | , updatedAt :: UTCTime 31 | } 32 | deriving stock (Eq, Generic, Show) 33 | deriving anyclass (FromRow, ToRow) 34 | deriving (Entity) 35 | via (GenericEntity '[TableName "repositories"] Repository) 36 | 37 | insertRepository :: Repository -> DBT IO () 38 | insertRepository repo = insert @Repository repo 39 | 40 | getRepository :: RepositoryId -> DBT IO (Maybe Repository) 41 | getRepository repoId = selectById @Repository (Only repoId) 42 | 43 | getRepositoriesByOrg :: OrganisationId -> DBT IO (Vector Repository) 44 | getRepositoriesByOrg orgId = selectManyByField @Repository [field| organisation_id |] (Only orgId) 45 | 46 | getRepositoryByName :: Text -> DBT IO (Maybe Repository) 47 | getRepositoryByName name = selectOneByField [field| repository_name |] (Only name) 48 | 49 | deleteRepository :: RepositoryId -> DBT IO () 50 | deleteRepository repoId = delete @Repository (Only repoId) 51 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | ghcid: dev 2 | dev: ## Start ghcid 3 | @ghcid --target lib:matchmaker --allow-eval --warnings 4 | 5 | start: ## Start the server 6 | @cabal run exe:matchmaker 7 | 8 | deps: ## Install the dependencies of the backend 9 | @command -v migrate >/dev/null || cabal install postgresql-simple-migration 10 | @cabal build --only-dependencies 11 | 12 | build: ## Build the project in fast mode 13 | @cabal build -O0 14 | 15 | clean: ## Remove compilation artifacts 16 | @cabal clean 17 | 18 | assets-deps: ## Install the dependencies of the frontend 19 | @cd assets/ && yarn 20 | 21 | assets-build: ## Build the web assets 22 | @cd assets/ && yarn webpack --config webpack/webpack.config.js 23 | 24 | assets-watch: ## Continuously rebuild the web assets 25 | @cd assets/ && yarn webpack -w --config webpack/webpack.config.js 26 | 27 | assets-clean: ## Remove JS artifacts 28 | @cd assets/ && rm -R node_modules 29 | 30 | db-init: ## Initialize the dev database 31 | @initdb -D _database 32 | 33 | db-start: ## Start the dev database 34 | @postgres -D _database 35 | 36 | db-setup: ## Setup the dev database 37 | @createdb matchmaker_dev 38 | @cabal exec -- migrate init "$(PG_CONNSTRING)" migrations 39 | @cabal exec -- migrate migrate "$(PG_CONNSTRING)" migrations 40 | 41 | db-reset: ## Reset the dev database 42 | @dropdb matchmaker_dev 43 | @make db-setup 44 | 45 | repl: ## Start a REPL 46 | @cabal repl 47 | 48 | test: ## Run the test suite 49 | @cabal test 50 | 51 | lint: ## Run the code linter (HLint) 52 | @find app test src -name "*.hs" | xargs -P $(PROCS) -I {} hlint --refactor-options="-i" --refactor {} 53 | 54 | format: style 55 | style: ## Run the code styler (stylish-haskell) 56 | @stylish-haskell -i -r src app test 57 | 58 | help: 59 | @grep -E '^[a-zA-Z_-]+:.*?## .*$$' $(MAKEFILE_LIST) | awk 'BEGIN {FS = ":.* ?## "}; {printf "\033[36m%-30s\033[0m %s\n", $$1, $$2}' 60 | 61 | UNAME := $(shell uname) 62 | 63 | ifeq ($(UNAME), Darwin) 64 | PROCS := $(shell sysctl -n hw.logicalcpu) 65 | else 66 | PROCS := $(shell nproc) 67 | endif 68 | 69 | .PHONY: all $(MAKECMDGOALS) 70 | 71 | .DEFAULT_GOAL := help 72 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | # Trigger the workflow on push or pull request, but only for the main branch 4 | on: 5 | pull_request: 6 | push: 7 | branches: ['main'] 8 | 9 | jobs: 10 | cabal: 11 | name: ${{ matrix.os }} / ghc ${{ matrix.ghc }} 12 | runs-on: ${{ matrix.os }} 13 | strategy: 14 | matrix: 15 | os: [ubuntu-latest] 16 | cabal: ['3.4.0.0'] 17 | ghc: ['8.10.4'] 18 | 19 | steps: 20 | - uses: actions/checkout@v2 21 | if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/main' 22 | 23 | - uses: haskell/actions/setup@v1 24 | id: setup-haskell-cabal 25 | name: Setup Haskell 26 | with: 27 | ghc-version: ${{ matrix.ghc }} 28 | cabal-version: ${{ matrix.cabal }} 29 | 30 | - name: Configure environment 31 | run: | 32 | echo '/usr/lib/postgresql/12/bin/' >> $GITHUB_PATH 33 | echo "/nix/var/nix/profiles/per-user/$USER/profile/bin" >> "$GITHUB_PATH" 34 | echo "/nix/var/nix/profiles/default/bin" >> "$GITHUB_PATH" 35 | echo 'NIX_PATH="nixpkgs=channel:nixos-unstable"' >> "$GITHUB_ENV" 36 | echo '$HOME/.ghcup/bin' >> $GITHUB_PATH 37 | echo 'HOME/.cabal/bin' >> $GITHUB_PATH 38 | echo 'HOME/.local/bin' >> $GITHUB_PATH 39 | 40 | - name: Install Nix 41 | run: | 42 | ./.github/workflows/install-nix.sh 43 | 44 | - name: Configure 45 | run: | 46 | cabal configure --enable-tests --test-show-details=direct 47 | 48 | - name: Freeze 49 | run: | 50 | nix-shell --run 'cabal freeze' 51 | 52 | - uses: actions/cache@v2 53 | name: Cache ~/.cabal/store 54 | with: 55 | path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }} 56 | key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }} 57 | 58 | - name: Running hlint 59 | run: nix-shell --run './.github/workflows/hlint-runner.sh' 60 | 61 | - name: Running stylish-haskell 62 | run: nix-shell --run './.github/workflows/stylish-haskell-runner.sh' 63 | 64 | - name: Install dependencies 65 | run: | 66 | nix-shell --run 'make deps' 67 | 68 | - name: Build 69 | run: | 70 | nix-shell --run 'make build' 71 | 72 | - name: Test 73 | run: | 74 | nix-shell --run 'make test' 75 | -------------------------------------------------------------------------------- /src/Model/UserModel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StrictData #-} 2 | module Model.UserModel where 3 | 4 | import DB.User 5 | import qualified Data.Map as M 6 | import Data.Password.Argon2 (Password, mkPassword) 7 | import qualified Data.Text as T 8 | import Data.Time 9 | import Data.UUID.V4 (nextRandom) 10 | import Web.Form 11 | import Web.Sessions 12 | 13 | data NewUserValidationError 14 | = EmptyUsername 15 | | EmptyDisplayName 16 | | TooShortPassword 17 | | InvalidEmailAddress 18 | | MissingField Text 19 | deriving Show 20 | 21 | instance ErrorToAssign NewUserValidationError where 22 | putErrorAssign err = 23 | case err of 24 | EmptyUsername -> putAssign "form_error_username" "Username cannot be empty" 25 | EmptyDisplayName -> putAssign "form_error_displayname" "Display name cannot be empty" 26 | TooShortPassword -> putAssign "form_error_password" "Password cannot be smaller than 8 characters" 27 | InvalidEmailAddress -> putAssign "form_error_email" "Email address is invalid" 28 | MissingField field -> putAssign ("form_error_" <> field) ("Missing required field: " <> field) 29 | 30 | validateNewUser :: [(Text,Text)] -> IO (FormValidation NewUserValidationError User) 31 | validateNewUser params = do 32 | let paramMap = M.fromList params 33 | ts <- getCurrentTime 34 | userId <- UserId <$> nextRandom 35 | hashedPassword <- traverse hashPassword $ validateShortPassword =<< lookupFormField MissingField "password" paramMap 36 | pure $ 37 | User userId 38 | <$> (validateUsername =<< lookupFormField MissingField "username" paramMap) 39 | <*> (validateEmailAddress =<< lookupFormField MissingField "email" paramMap) 40 | <*> (validateDisplayName =<< lookupFormField MissingField "displayname" paramMap) 41 | <*> hashedPassword 42 | <*> pure ts 43 | <*> pure ts 44 | 45 | validateUsername :: Text -> FormValidation NewUserValidationError Text 46 | validateUsername name = if T.null name then fieldError EmptyUsername else pure name 47 | 48 | validateDisplayName:: Text -> FormValidation NewUserValidationError Text 49 | validateDisplayName name = if T.null name then fieldError EmptyDisplayName else pure name 50 | 51 | validateShortPassword :: Text -> FormValidation NewUserValidationError Password 52 | validateShortPassword password = 53 | if T.length password < 8 54 | then fieldError TooShortPassword 55 | else Result $ mkPassword password 56 | 57 | validateEmailAddress :: Text -> FormValidation NewUserValidationError Text 58 | validateEmailAddress email = 59 | if not . T.isInfixOf "@" $ email 60 | then fieldError InvalidEmailAddress 61 | else pure email 62 | -------------------------------------------------------------------------------- /src/Templates.hs: -------------------------------------------------------------------------------- 1 | module Templates where 2 | 3 | import qualified Data.HashMap.Strict as HM 4 | import qualified Data.HashMap.Strict as HashMap 5 | import Foundation 6 | import System.IO.Error (tryIOError) 7 | import Templates.Types (ModuleName (..), TemplateAssigns (..), 8 | TemplateName (..)) 9 | import Text.Ginger (GVal, Source, SourceName, ToGVal (..), makeContextHtml, 10 | parseGingerFile, runGinger) 11 | import Text.Ginger.Html (htmlSource) 12 | import Web.Helpers (debug) 13 | import Web.Sessions (UserAssigns (UserAssigns), getAllUserAssigns, popAssign) 14 | import Web.Types (MatchmakerError) 15 | import Yesod.Core 16 | 17 | render :: ModuleName -> TemplateName -> TemplateAssigns -> Handler Html 18 | render (ModuleName moduleName) (TemplateName templateName) assigns = do 19 | let templatePath = "./src/Templates/" <> moduleName <> "/" <> templateName <> ".html" 20 | mUserAssigns <- getAllUserAssigns 21 | let (TemplateAssigns hm) = mkAssigns assigns mUserAssigns 22 | debug ("Assigns: " <> show hm) 23 | let contextLookup = flip scopeLookup hm 24 | let context = makeContextHtml contextLookup 25 | eTemplate <- liftIO $ parseGingerFile resolver (toString templatePath) 26 | case eTemplate of 27 | Left err -> pure $ show err 28 | Right template -> do 29 | popAssign "flash_alert_info" 30 | popAssign "flash_alert_error" 31 | pure . preEscapedToMarkup . htmlSource $ runGinger context template 32 | 33 | mkAssigns :: TemplateAssigns -> Maybe UserAssigns -> TemplateAssigns 34 | mkAssigns (TemplateAssigns templateAssigns) (Just (UserAssigns userAssigns)) = 35 | TemplateAssigns $ HM.union templateAssigns userAssigns 36 | mkAssigns ta Nothing = ta 37 | 38 | resolver :: SourceName -> IO (Maybe Source) 39 | resolver templatePath = do 40 | e <- liftIO $ tryIOError $ readFile templatePath 41 | case e of 42 | Right contents -> pure (Just contents) 43 | Left _ -> pure Nothing 44 | 45 | -- Wrapper around HashMap.lookup that applies toGVal to the value found. 46 | -- Any value referenced in a template, returned from within a template, or used 47 | -- in a template context, will be a GVal 48 | scopeLookup :: 49 | (Hashable k, Eq k, ToGVal m b) => 50 | k -> 51 | HashMap.HashMap k b -> 52 | GVal m 53 | scopeLookup key context = toGVal $ HashMap.lookup key context 54 | 55 | errorHandler :: 56 | HasCallStack => 57 | MatchmakerError -> 58 | Handler Html 59 | errorHandler err = do 60 | let assigns = TemplateAssigns $ HM.fromList [("error", toStrict $ show err), ("stacktrace", toText $ prettyCallStack callStack)] 61 | render (ModuleName "Error") (TemplateName "500") assigns 62 | -------------------------------------------------------------------------------- /src/Web/Sessions/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | 3 | -- | 4 | -- A session has 2 parts in the matchmaker architecture. The first is managed by yesod, which 5 | -- is the client session. These are cookies (yesod handles encryption) that live on the users 6 | -- browser. We keep the data on the client side minimal, it is just a @UUID@ that corresponds 7 | -- to some state that we maintain on the server. This is the second part of the session; an in 8 | -- memory data structure (@HM.HashMap@ for now) that keeps track of various pieces of user state. 9 | -- The functions in this section are helpers for initializing, modifying, and cleaning up the 10 | -- state that we maintain on the server. 11 | module Web.Sessions.Server where 12 | 13 | import Control.Concurrent 14 | import qualified Data.HashMap.Strict as HM 15 | import Data.Time (NominalDiffTime, UTCTime, addUTCTime, getCurrentTime) 16 | import Data.UUID (UUID, fromText) 17 | import Data.UUID.V4 18 | 19 | data Session a = Session 20 | { sessionId :: UUID, 21 | sessionValidUntil :: UTCTime, 22 | sessionContent :: a 23 | } 24 | deriving (Show, Eq, Functor) 25 | 26 | type SessionManager a = TVar (HashMap UUID (Session a)) 27 | 28 | sessionTTL :: NominalDiffTime 29 | sessionTTL = 36000 30 | 31 | makeSession :: a -> IO (Session a) 32 | makeSession content = do 33 | uuid <- nextRandom 34 | now <- getCurrentTime 35 | let validUntil = addUTCTime sessionTTL now 36 | pure $ Session uuid validUntil content 37 | 38 | insertServerSession :: SessionManager a -> Session a -> IO () 39 | insertServerSession sessions sessionVal = 40 | atomically $ modifyTVar' sessions $ HM.insert (sessionId sessionVal) sessionVal 41 | 42 | getServerSession :: SessionManager a -> Text -> IO (Maybe (Session a)) 43 | getServerSession sessions sid = 44 | fmap join $ forM (fromText sid) $ \sessionId -> do 45 | s <- readTVarIO sessions 46 | pure $ HM.lookup sessionId s 47 | 48 | upsertServerSession :: 49 | SessionManager a -> 50 | Maybe Text -> 51 | (Maybe (Session a) -> a) -> 52 | IO (Session a) 53 | upsertServerSession manager mSid f = do 54 | mSessionAssigns <- join <$> traverse (getServerSession manager) mSid 55 | s <- makeSession . f $ mSessionAssigns 56 | insertServerSession manager s 57 | pure s 58 | 59 | modifyServerSession :: 60 | SessionManager a -> 61 | Text -> 62 | (a -> a) -> 63 | IO (Maybe (Session a)) 64 | modifyServerSession manager sid f = do 65 | mSessionAssigns <- getServerSession manager sid 66 | forM mSessionAssigns $ \sessionAssigns -> do 67 | s <- makeSession . f $ sessionContent sessionAssigns 68 | insertServerSession manager s 69 | pure s 70 | 71 | createSessionManager :: IO (SessionManager a) 72 | createSessionManager = do 73 | storage <- newTVarIO HM.empty 74 | forkIO $ maintainServerSessions storage 75 | pure storage 76 | 77 | maintainServerSessions :: SessionManager a -> IO () 78 | maintainServerSessions sessions = do 79 | now <- getCurrentTime 80 | atomically $ modifyTVar' sessions $ \m -> HM.filter (stillValid now) m 81 | threadDelay 1000000 82 | maintainServerSessions sessions 83 | where 84 | stillValid currTime sess = sessionValidUntil sess > currTime 85 | 86 | -------------------------------------------------------------------------------- /test/DB/OrganisationSpec.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE OverloadedLists #-} 3 | {-# OPTIONS_GHC -Wno-unused-imports #-} 4 | 5 | module DB.OrganisationSpec where 6 | 7 | import Data.Password.Argon2 8 | import Data.UUID.V4 9 | import Relude.Unsafe (read) 10 | import Test.Hspec (Spec) 11 | import Test.Hspec.DB (describeDB, itDB) 12 | import Test.Hspec.Expectations.Lifted (expectationFailure, shouldReturn) 13 | 14 | import DB.Organisation (Organisation (..), OrganisationId (..), 15 | UserOrganisationId (..), attachUser, getAdmins, 16 | getAllUserOrganisations, getOrganisationByName, 17 | getUserOrganisation, getUserOrganisationById, getUsers, 18 | insertOrganisation, makeAdmin) 19 | import DB.SpecHelpers (migrate) 20 | import DB.User 21 | 22 | user1 :: User 23 | user1 = 24 | let userId = UserId (read "4e511d7a-a464-11eb-b30b-5405db82c3cd") 25 | username = "pmpc" 26 | email = "pmpc@example.com" 27 | displayName = "Plonk McPlonkface" 28 | password = PasswordHash "foobar2000" 29 | createdAt = read "2021-04-23 10:00:00 UTC" 30 | updatedAt = read "2021-04-23 10:00:00 UTC" 31 | in User{..} 32 | 33 | user2 :: User 34 | user2 = 35 | let userId = UserId (read "44495a98-a475-11eb-94f3-5405db82c3cd") 36 | username = "blue_devil" 37 | email = "princess_jack@example.com" 38 | displayName = "Princess Jack Moonshine" 39 | password = PasswordHash "DRINK!" 40 | createdAt = read "2021-04-23 14:00:00 UTC" 41 | updatedAt = read "2021-04-23 14:30:00 UTC" 42 | in User{..} 43 | 44 | organisation1 :: Organisation 45 | organisation1 = 46 | let organisationId = OrganisationId (read "6e9b2ff8-a469-11eb-b05c-5405db82c3cd") 47 | organisationName = "haskell-servant" 48 | createdAt = read "2021-03-30 01:00:00 UTC" 49 | updatedAt = read "2021-03-30 01:00:00 UTC" 50 | in Organisation{..} 51 | 52 | organisation2 :: Organisation 53 | organisation2 = 54 | let organisationId = OrganisationId (read "b63ad088-a474-11eb-9236-5405db82c3cd") 55 | organisationName = "ghchq" 56 | createdAt = read "2021-04-10 01:00:00 UTC" 57 | updatedAt = read "2021-04-11 01:00:00 UTC" 58 | in Organisation{..} 59 | 60 | spec :: Spec 61 | spec = describeDB migrate "users" $ do 62 | itDB "Attach user1 to organisation1" $ do 63 | let uid = userId user1 64 | let oid = organisationId organisation1 65 | let uoId = UserOrganisationId (read "e801f560-a4dd-11eb-844b-5405db82c3cd") 66 | insertOrganisation organisation1 67 | insertUser user1 68 | attachUser uid oid uoId 69 | uos <- getUserOrganisationById uoId 70 | getUserOrganisation uid oid 71 | `shouldReturn` uos 72 | itDB "Look for admins in the organisation" $ do 73 | let uid = userId user2 74 | let oid = organisationId organisation2 75 | let uoId = UserOrganisationId (read "f865652c-a4dd-11eb-8a43-5405db82c3cd") 76 | insertOrganisation organisation2 77 | insertUser user2 78 | attachUser uid oid uoId 79 | makeAdmin uid oid 80 | uo <- getUserOrganisation uid oid 81 | print uo 82 | getAdmins (organisationId organisation2) 83 | `shouldReturn` [user2] 84 | -------------------------------------------------------------------------------- /src/DB/User.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE UndecidableInstances #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans -Wno-redundant-constraints #-} 5 | module DB.User where 6 | 7 | import Data.Aeson (FromJSON (..), ToJSON (..)) 8 | import Data.Password.Argon2 (Argon2, Password, PasswordCheck (..), PasswordHash) 9 | import qualified Data.Password.Argon2 as Argon2 10 | import Data.Time (UTCTime) 11 | import Data.UUID (UUID) 12 | import qualified Data.UUID as UUID 13 | import Database.PostgreSQL.Entity 14 | import Database.PostgreSQL.Entity.Types 15 | import Database.PostgreSQL.Simple (Only (Only)) 16 | import Database.PostgreSQL.Simple.FromField (FromField (..)) 17 | import Database.PostgreSQL.Simple.FromRow (FromRow (..)) 18 | import Database.PostgreSQL.Simple.ToField (ToField (..)) 19 | import Database.PostgreSQL.Simple.ToRow (ToRow (..)) 20 | import Database.PostgreSQL.Transact (DBT) 21 | import GHC.TypeLits (ErrorMessage (..), TypeError) 22 | 23 | newtype UserId 24 | = UserId { getUserId :: UUID } 25 | deriving stock (Eq, Generic) 26 | deriving newtype (FromField, FromJSON, Show, ToField, ToJSON) 27 | 28 | instance ToText UserId where 29 | toText (UserId uuid) = UUID.toText uuid 30 | 31 | data User 32 | = User { userId :: UserId 33 | , username :: Text 34 | , email :: Text 35 | , displayName :: Text 36 | , password :: PasswordHash Argon2 37 | , createdAt :: UTCTime 38 | , updatedAt :: UTCTime 39 | } 40 | deriving stock (Eq, Generic, Show) 41 | deriving anyclass (FromRow, ToRow) 42 | deriving (Entity) 43 | via (GenericEntity '[TableName "users"] User) 44 | 45 | -- | Type error! Do not use 'toJSON' on a 'Password'! 46 | instance TypeError (ErrMsg "JSON") => ToJSON Password where 47 | toJSON = error "unreachable" 48 | 49 | type ErrMsg e = 'Text "Warning! Tried to convert plain-text Password to " ':<>: 'Text e ':<>: 'Text "!" 50 | ':$$: 'Text " This is likely a security leak. Please make sure whether this was intended." 51 | ':$$: 'Text " If this is intended, please use 'unsafeShowPassword' before converting to " ':<>: 'Text e 52 | ':$$: 'Text "" 53 | 54 | instance FromJSON Password where 55 | parseJSON = fmap Argon2.mkPassword . parseJSON 56 | 57 | deriving via Text instance ToField (PasswordHash a) 58 | deriving via Text instance FromField (PasswordHash a) 59 | 60 | -- Database operations 61 | 62 | hashPassword :: (MonadIO m) => Password -> m (PasswordHash Argon2) 63 | hashPassword = Argon2.hashPassword 64 | 65 | validatePassword :: Password -> PasswordHash Argon2 -> Bool 66 | validatePassword inputPassword hashedPassword = 67 | Argon2.checkPassword inputPassword hashedPassword == PasswordCheckSuccess 68 | 69 | insertUser :: HasCallStack => User -> DBT IO () 70 | insertUser user = insert @User user 71 | 72 | getUserById :: HasCallStack => UserId -> DBT IO (Maybe User) 73 | getUserById userId = selectById (Only userId) 74 | 75 | getUserByUsername :: HasCallStack => Text -> DBT IO (Maybe User) 76 | getUserByUsername username = selectOneByField [field| username |] (Only username) 77 | 78 | getUserByEmail :: HasCallStack => Text -> DBT IO (Maybe User) 79 | getUserByEmail email = selectOneByField [field| email |] (Only email) 80 | 81 | deleteUser :: HasCallStack => UserId -> DBT IO () 82 | deleteUser userId = delete @User (Only userId) 83 | -------------------------------------------------------------------------------- /src/Environment.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StrictData #-} 2 | module Environment 3 | ( MatchmakerEnv (..) 4 | , PoolConfig(..) 5 | , getMatchmakerEnv 6 | ) where 7 | 8 | 9 | import Control.Monad.Logger (LogLevel (..)) 10 | import Data.Time (NominalDiffTime) 11 | import qualified Database.PostgreSQL.Simple as PG 12 | import Env (AsUnread (unread), Error (..), Parser, Reader, help, parse, str, 13 | var) 14 | import Prelude hiding (Reader) 15 | 16 | data MatchmakerEnv 17 | = MatchmakerEnv { matchmakerPgConfig :: PG.ConnectInfo 18 | , matchmakerPoolConfig :: PoolConfig 19 | , matchmakerHttpPort :: Word16 20 | , matchmakerLogLevel :: LogLevel 21 | } 22 | deriving (Show) 23 | 24 | data PoolConfig 25 | = PoolConfig { subPools :: Int 26 | , connectionTimeout :: NominalDiffTime 27 | , connections :: Int 28 | } 29 | deriving (Show) 30 | 31 | 32 | parseConnectInfo :: Parser Error PG.ConnectInfo 33 | parseConnectInfo = 34 | PG.ConnectInfo <$> var str "DB_HOST" (help "PostgreSQL host") 35 | <*> var port "DB_PORT" (help "PostgreSQL port") 36 | <*> var str "DB_USER" (help "PostgreSQL user") 37 | <*> var str "DB_PASSWORD" (help "PostgreSQL password") 38 | <*> var str "DB_DATABASE" (help "Control-Plane database") 39 | 40 | parsePoolConfig :: Parser Error PoolConfig 41 | parsePoolConfig = 42 | PoolConfig <$> var (int >=> nonNegative) "DB_SUB_POOLS" (help "Number of sub-pools") 43 | <*> var timeout "DB_TIMEOUT" (help "Timeout for each connection") 44 | <*> var (int >=> nonNegative) "DB_POOL_CONNECTIONS" (help "Number of connections per sub-pool") 45 | 46 | parsePort :: Parser Error Word16 47 | parsePort = var port "MATCHMAKER_PORT" (help "HTTP Port for Matchmaker") 48 | 49 | parseLogLevel :: Parser Error LogLevel 50 | parseLogLevel = var readLogLevel "MATCHMAKER_LOG_LEVEL" (help "Log level for Matchmaker") 51 | 52 | parseConfig :: Parser Error MatchmakerEnv 53 | parseConfig = 54 | MatchmakerEnv 55 | <$> parseConnectInfo 56 | <*> parsePoolConfig 57 | <*> parsePort 58 | <*> parseLogLevel 59 | 60 | getMatchmakerEnv :: IO MatchmakerEnv 61 | getMatchmakerEnv = Env.parse id parseConfig 62 | 63 | -- Env parser helpers 64 | 65 | int :: Reader Error Int 66 | int i = 67 | case readMaybe i of 68 | Nothing -> Left . unread . show $ i 69 | Just i' -> Right i' 70 | 71 | port :: Reader Error Word16 72 | port p = 73 | case int p of 74 | Left err -> Left err 75 | Right intPort -> 76 | if intPort >= 1 && intPort <= 65535 77 | then Right $ fromIntegral intPort 78 | else Left . unread . show $ p 79 | 80 | nonNegative :: Int -> Either Error Int 81 | nonNegative nni = 82 | if nni >= 0 83 | then Right nni 84 | else Left . unread . show $ nni 85 | 86 | timeout :: Reader Error NominalDiffTime 87 | timeout t = second fromIntegral (int >=> nonNegative $ t) 88 | 89 | readLogLevel :: Reader Error LogLevel 90 | readLogLevel ll = do 91 | ll' <- str ll 92 | case ll' of 93 | "debug" -> Right LevelDebug 94 | "info" -> Right LevelInfo 95 | "warn" -> Right LevelWarn 96 | "error" -> Right LevelError 97 | "silent" -> Right $ LevelOther "silent" 98 | loglevel -> Left . unread $ loglevel <> " is not a valid option for MATCHMAKER_LOG_LEVEL" 99 | -------------------------------------------------------------------------------- /src/Web/Sessions.hs: -------------------------------------------------------------------------------- 1 | module Web.Sessions 2 | ( UserAssigns (..), 3 | module Web.Sessions, 4 | ) 5 | where 6 | 7 | import DB.User (UserId (..)) 8 | import qualified Data.HashMap.Strict as HM 9 | import qualified Data.UUID as UUID 10 | import Foundation 11 | import Prelude 12 | import Web.Sessions.Server (Session (..), getServerSession, modifyServerSession, 13 | upsertServerSession) 14 | import Web.Sessions.Types (UserAssigns (..)) 15 | import Yesod.Core 16 | 17 | lookupClientSession :: MonadHandler m => Text -> m (Maybe Text) 18 | lookupClientSession = lookupSession 19 | 20 | setClientSession :: MonadHandler m => Text -> Text -> m () 21 | setClientSession = setSession 22 | 23 | getClientSessions :: MonadHandler m => m SessionMap 24 | getClientSessions = getSession 25 | 26 | clearClientSession :: MonadHandler m => Text -> m () 27 | clearClientSession = deleteSession 28 | 29 | clientSessionIdentifier :: Text 30 | clientSessionIdentifier = "sid" 31 | 32 | markAuthenticated :: UserId -> Handler () 33 | markAuthenticated uId = putAssign "user_id" (toText uId) 34 | 35 | getUserIdFromSession :: Handler (Maybe UserId) 36 | getUserIdFromSession = readAssign "user_id" (fmap UserId . UUID.fromText) 37 | 38 | getAllUserAssigns :: Handler (Maybe UserAssigns) 39 | getAllUserAssigns = do 40 | Foundation {appSessionManager} <- getYesod 41 | mClientSession <- lookupSession clientSessionIdentifier 42 | liftIO . fmap join $ 43 | forM mClientSession $ \sid -> do 44 | mSession <- getServerSession appSessionManager sid 45 | pure $ sessionContent <$> mSession 46 | 47 | putAssign :: Text -> Text -> Handler () 48 | putAssign key value = do 49 | Foundation {appSessionManager} <- getYesod 50 | mClientSid <- lookupSession clientSessionIdentifier 51 | 52 | serverSession <- 53 | liftIO $ 54 | upsertServerSession appSessionManager mClientSid (upsertUserAssigns key value) 55 | 56 | void $ setClientSession clientSessionIdentifier (UUID.toText $ sessionId serverSession) 57 | 58 | 59 | readAssign :: Text -> (Text -> Maybe a) -> Handler (Maybe a) 60 | readAssign key f = do 61 | assign <- fetchAssign key 62 | pure $ f =<< assign 63 | 64 | fetchAssign :: Text -> Handler (Maybe Text) 65 | fetchAssign key = do 66 | Foundation {appSessionManager} <- getYesod 67 | mClientSession <- lookupSession clientSessionIdentifier 68 | liftIO . fmap join $ 69 | forM mClientSession $ \sid -> do 70 | mSession <- getServerSession appSessionManager sid 71 | pure $ mSession >>= lookupUserAssign key . sessionContent 72 | 73 | popAssign :: Text -> Handler (Maybe Text) 74 | popAssign key = do 75 | Foundation {appSessionManager} <- getYesod 76 | mClientSession <- lookupSession clientSessionIdentifier 77 | 78 | liftIO . fmap join $ 79 | forM mClientSession $ \sid -> do 80 | mSession <- getServerSession appSessionManager sid 81 | let mAssign = mSession >>= lookupUserAssign key . sessionContent 82 | forM mAssign $ \assign -> 83 | modifyServerSession appSessionManager sid (removeUserAssign key) >> pure assign 84 | 85 | upsertUserAssigns :: Text -> Text -> Maybe (Session UserAssigns) -> UserAssigns 86 | upsertUserAssigns key value Nothing = UserAssigns $ HM.insert key value HM.empty 87 | upsertUserAssigns key value (Just Session {..}) = 88 | UserAssigns 89 | . HM.insert key value 90 | . getUserAssigns 91 | $ sessionContent 92 | 93 | removeUserAssign :: Text -> UserAssigns -> UserAssigns 94 | removeUserAssign key = UserAssigns . HM.delete key . getUserAssigns 95 | 96 | lookupUserAssign :: Text -> UserAssigns -> Maybe Text 97 | lookupUserAssign key = HM.lookup key . getUserAssigns 98 | -------------------------------------------------------------------------------- /assets/layout.jinja.template: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | Matchmaker 8 | 9 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 |
29 |
30 |
{{ flash_alert_info|raw }}
31 |
{{ flash_alert_error|raw }}
32 | {% block content%} 33 | {% endblock content %} 34 |
35 | 36 | 53 |
54 | 55 | 56 | 57 | -------------------------------------------------------------------------------- /src/DB/Organisation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedLists #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | module DB.Organisation where 4 | 5 | import Data.Aeson (FromJSON, ToJSON) 6 | import Data.Time (UTCTime) 7 | import Data.UUID (UUID) 8 | import Database.PostgreSQL.Entity 9 | import Database.PostgreSQL.Simple (FromRow, Only (Only), ToRow) 10 | import Database.PostgreSQL.Simple.FromField (FromField) 11 | import Database.PostgreSQL.Simple.ToField (ToField) 12 | import Database.PostgreSQL.Transact (DBT) 13 | 14 | import DB.User (User, UserId) 15 | import Data.Maybe (fromJust) 16 | import Data.Vector (Vector) 17 | import Database.PostgreSQL.Entity.DBT (QueryNature (Select), query, queryOne, 18 | query_) 19 | import Database.PostgreSQL.Entity.Types 20 | import Database.PostgreSQL.Simple.SqlQQ (sql) 21 | 22 | newtype OrganisationId 23 | = OrganisationId { getOrganisationId :: UUID } 24 | deriving stock (Eq, Generic) 25 | deriving newtype (FromField, FromJSON, Show, ToField, ToJSON) 26 | 27 | data Organisation 28 | = Organisation { organisationId :: OrganisationId 29 | , organisationName :: Text 30 | , createdAt :: UTCTime 31 | , updatedAt :: UTCTime 32 | } 33 | deriving stock (Eq, Generic, Show) 34 | deriving anyclass (FromRow, ToRow) 35 | deriving (Entity) 36 | via (GenericEntity '[TableName "organisations"] Organisation) 37 | 38 | newtype UserOrganisationId 39 | = UserOrganisationId { getUserOrganisationId :: UUID } 40 | deriving stock (Eq, Generic) 41 | deriving newtype (FromField, FromJSON, Show, ToField, ToJSON) 42 | 43 | data UserOrganisation 44 | = UserOrganisation { userOrganisationId :: UserOrganisationId 45 | , userId :: UserId 46 | , organisationId :: OrganisationId 47 | , isAdmin :: Bool 48 | } 49 | deriving stock (Eq, Generic, Show) 50 | deriving anyclass (FromRow, ToRow) 51 | deriving Entity 52 | via (GenericEntity '[TableName "user_organisation"] UserOrganisation) 53 | 54 | insertOrganisation :: Organisation -> DBT IO () 55 | insertOrganisation org = insert @Organisation org 56 | 57 | getOrganisationById :: OrganisationId -> DBT IO (Maybe Organisation) 58 | getOrganisationById orgId = selectById @Organisation (Only orgId) 59 | 60 | getOrganisationByName :: Text -> DBT IO (Maybe Organisation) 61 | getOrganisationByName name = selectOneByField [field| organisation_name |] (Only name) 62 | 63 | deleteOrganisation :: OrganisationId -> DBT IO () 64 | deleteOrganisation orgId = delete @Organisation (Only orgId) 65 | 66 | getAllUserOrganisations :: DBT IO (Vector UserOrganisation) 67 | getAllUserOrganisations = query_ Select (_select @UserOrganisation) 68 | 69 | getUserOrganisationById :: UserOrganisationId -> DBT IO (Maybe UserOrganisation) 70 | getUserOrganisationById uoId = selectById @UserOrganisation (Only uoId) 71 | 72 | getUserOrganisation :: UserId -> OrganisationId -> DBT IO (Maybe UserOrganisation) 73 | getUserOrganisation userId orgId = queryOne Select q (userId, orgId) 74 | where q = _selectWhere @UserOrganisation [[field| user_id |], [field| organisation_id |]] 75 | 76 | makeAdmin :: UserId -> OrganisationId -> DBT IO () 77 | makeAdmin userId organisationId = do 78 | uo <- fromJust <$> getUserOrganisation userId organisationId 79 | let newUO = uo{isAdmin = True} 80 | update @UserOrganisation newUO 81 | 82 | attachUser :: UserId -> OrganisationId -> UserOrganisationId -> DBT IO () 83 | attachUser userId organisationId uoId = do 84 | insert @UserOrganisation (UserOrganisation uoId userId organisationId False) 85 | 86 | getUsers :: OrganisationId -> DBT IO (Vector User) 87 | getUsers orgId = query Select q (Only orgId) 88 | where q = [sql| 89 | SELECT u.user_id, u.username, u.email, u.display_name, u.password, u.created_at, u.updated_at 90 | FROM users AS u 91 | JOIN user_organisation AS uo 92 | ON u.user_id = uo.user_id 93 | WHERE uo.organisation_id = ? 94 | |] 95 | 96 | getAdmins :: OrganisationId -> DBT IO (Vector User) 97 | getAdmins orgId = query Select q (Only orgId) 98 | where q = [sql| 99 | SELECT u.user_id, u.username, u.email, u.display_name, u.password, u.created_at, u.updated_at 100 | FROM users AS u 101 | JOIN user_organisation AS uo 102 | ON uo.user_id = u.user_id 103 | WHERE uo.organisation_id = ? AND uo.is_admin = true 104 | |] 105 | -------------------------------------------------------------------------------- /src/Templates/Account/signup.html: -------------------------------------------------------------------------------- 1 | {% extends '../Layout/layout.html' %} 2 | {% block flash_alert_info %} 3 | {% endblock flash_alert_info %} 4 | {% block flash_alert_error %} 5 | {% endblock flash_alert_error %} 6 | {% block content %} 7 | 8 |
9 |
10 |
11 |
12 |
13 |
14 |
Sign-up!
15 |
16 |
17 | 18 | 21 |
22 | {{ form_error_displayname }} 23 |
24 |
25 |
26 | 27 | 30 |
31 | {{ form_error_username }} 32 |
33 |
34 |
35 | 36 | 39 |
40 | {{ form_error_email }} 41 |
42 |
43 |
44 | 45 | 49 |
50 | {{ form_error_password }} 51 |
52 |
53 | 54 | 58 |
59 | 60 |
61 |
62 |
63 |
64 | 65 |
66 | 67 | {% endblock %} 68 | -------------------------------------------------------------------------------- /src/Templates/Home/index.html: -------------------------------------------------------------------------------- 1 | {% extends "../Layout/layout.html" %} 2 | {% block content %} 3 | 4 |
5 |
6 |
8 |

Haskell Foundation presents…

9 |

10 | Matchmaker:
Find your open-soulmate <💜> 11 |

12 |
13 |
14 |
15 | 17 | 18 | 21 | 22 |
23 |
24 |

25 | Maintainer? 26 |

27 |

28 | Broadcast your calls to potential contributors! 29 |

30 | 32 | Register your project 33 | 35 | 36 | 38 | 39 | 40 |
41 |
42 |
43 |
44 | 46 | 47 | 49 | 50 |
51 |
52 |

53 | Contributor? 54 |

55 |

56 | Find open-source projects that need your help! 57 |

58 | 60 | Browse projects 61 | 63 | 64 | 66 | 67 | 68 |
69 |
70 |
71 |
72 |
73 | hackage 75 |
76 |
77 |
78 | 79 | {% endblock %} 80 | -------------------------------------------------------------------------------- /src/Server.hs: -------------------------------------------------------------------------------- 1 | module Server where 2 | 3 | import Colourista.IO (greenMessage) 4 | import Foundation 5 | import Handler () 6 | import Yesod.Core 7 | import qualified Yesod.Core.Types as YT 8 | 9 | import Control.Monad.Logger (liftLoc) 10 | import Data.Default.Class 11 | import Database.PostgreSQL.Entity.DBT (mkPool) 12 | import Environment 13 | import Language.Haskell.TH.Syntax (qLocation) 14 | import Network.HTTP.Client.TLS (getGlobalManager) 15 | import Network.Wai (Middleware) 16 | import Network.Wai.Handler.Warp (Settings, defaultSettings, 17 | defaultShouldDisplayException, runSettings, 18 | setOnException, setPort) 19 | import Network.Wai.Logger (clockDateCacher) 20 | import Network.Wai.Middleware.Cors (simpleCors) 21 | import Network.Wai.Middleware.RequestLogger (Destination (Logger), 22 | IPAddrSource (..), 23 | OutputFormat (..), destination, 24 | mkRequestLogger, outputFormat) 25 | import Network.Wai.Middleware.Static (noDots, staticPolicy) 26 | import System.Log.FastLogger (LoggerSet, defaultBufSize, newStdoutLoggerSet, 27 | toLogStr) 28 | import Web.Middleware (heartbeat) 29 | import Web.Sessions.Server (createSessionManager) 30 | 31 | -- | This function allocates resources (such as a database connection pool), 32 | -- performs initialization and returns a foundation datatype value. This is also 33 | -- the place to put your migrate statements to have automatic database 34 | -- migrations handled by Yesod. 35 | makeFoundation :: MatchmakerEnv -> IO Foundation 36 | makeFoundation MatchmakerEnv{..} = do 37 | let PoolConfig{..} = matchmakerPoolConfig 38 | appPort = matchmakerHttpPort 39 | appLogLevel = matchmakerLogLevel 40 | appRoot = Just "/" 41 | appPgPool <- mkPool matchmakerPgConfig subPools connectionTimeout connections 42 | appHttpManager <- getGlobalManager 43 | 44 | -- TODO(jonathan): If we want to add structured logging we should do it here 45 | appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger 46 | appSessionManager <- createSessionManager 47 | 48 | return Foundation {..} 49 | where 50 | makeYesodLogger :: LoggerSet -> IO YT.Logger 51 | makeYesodLogger loggerSet' = do 52 | (getter, _) <- clockDateCacher 53 | return $! YT.Logger loggerSet' getter 54 | 55 | makeMiddleware :: Foundation -> IO Middleware 56 | makeMiddleware foundation = do 57 | logWare <- makeLogWare foundation 58 | pure 59 | $ logWare 60 | . defaultMiddlewaresNoLogging 61 | . heartbeat 62 | . simpleCors 63 | . staticPolicy noDots 64 | 65 | -- TODO(jonathan): We probably weant to be more considerate about our log levels 66 | -- but this will do for now 67 | makeLogWare :: Foundation -> IO Middleware 68 | makeLogWare foundation = 69 | mkRequestLogger def 70 | { outputFormat = 71 | if LevelError <= appLogLevel foundation 72 | then Detailed True 73 | else Apache FromSocket 74 | , destination = Logger $ YT.loggerSet $ appLogger foundation 75 | } 76 | 77 | -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and 78 | -- applying some additional middlewares. 79 | makeWaiApplication :: Foundation -> IO Application 80 | makeWaiApplication foundation = do 81 | matchmakerMiddleware <- makeMiddleware foundation 82 | appPlain <- toWaiAppPlain foundation 83 | return $ matchmakerMiddleware appPlain 84 | 85 | -- | Warp settings for the given foundation value. 86 | warpSettings :: Foundation -> Settings 87 | warpSettings foundation = 88 | setPort (fromIntegral $ appPort foundation) 89 | $ setOnException (\_req e -> 90 | when (defaultShouldDisplayException e) $ messageLoggerSource 91 | foundation 92 | (appLogger foundation) 93 | $(qLocation >>= liftLoc) 94 | "yesod" 95 | LevelError 96 | (toLogStr $ "Exception from Warp: " ++ show e)) 97 | defaultSettings 98 | 99 | -- | For yesod devel, return the Warp settings and WAI Application. 100 | -- TODO(jonathan): Need to get this working 101 | getApplicationDev :: IO (Settings, Application) 102 | getApplicationDev = do 103 | settings <- getMatchmakerEnv 104 | foundation <- makeFoundation settings 105 | let wsettings = warpSettings foundation 106 | app <- makeWaiApplication foundation 107 | return (wsettings, app) 108 | 109 | -- | The @main@ function for an executable running this site. 110 | appMain :: IO () 111 | appMain = do 112 | -- Get the settings from the environment 113 | matchmakerEnv@MatchmakerEnv{..} <- getMatchmakerEnv 114 | 115 | -- Generate the foundation from the settings 116 | foundation <- makeFoundation matchmakerEnv 117 | 118 | -- Generate a WAI Application from the foundation 119 | app <- makeWaiApplication foundation 120 | let listenAddr = "http://localhost:" <> show matchmakerHttpPort 121 | greenMessage 122 | $ "<💜> Matchmaker listening on " <> listenAddr 123 | <> "\n" 124 | <> "<💜> Log level is " <> show matchmakerLogLevel 125 | 126 | -- Run the application with Warp 127 | runSettings (warpSettings foundation) app 128 | 129 | -------------------------------------------------------------------------------- /src/Foundation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | module Foundation where 3 | 4 | import DB 5 | import Data.Pool 6 | import qualified Database.PostgreSQL.Entity.DBT as ENT 7 | import Database.PostgreSQL.Simple 8 | import Database.PostgreSQL.Transact (DBT) 9 | import Network.HTTP.Client (HasHttpManager (..), Manager) 10 | import Prelude hiding (get) 11 | import Web.Router (router) 12 | import Web.Sessions.Server (SessionManager) 13 | import Web.Sessions.Types (UserAssigns) 14 | import Yesod.Core 15 | import Yesod.Core.Types 16 | 17 | -- | Foundation is the core data type for our application, it is available as a reader argument 18 | -- in the @Handler@ monad (which is created by mkYesodData). Foundation can be accessed by calling 19 | -- the helper function 'getYesod'. This is where things like in memory sessions, db pools, and 20 | -- http managers should be stored. Generally environment variables are parsed at startup and 21 | -- put into this data type. 22 | data Foundation = Foundation 23 | { appPgPool :: Pool Connection 24 | , appRoot :: Maybe Text 25 | , appPort :: Word16 26 | , appHttpManager :: Manager 27 | , appLogger :: Logger 28 | , appLogLevel :: LogLevel 29 | , appSessionManager :: SessionManager UserAssigns 30 | } 31 | 32 | -- | This is a magical piece of template haskell that does 1/2 of the routing work for yesod. 33 | -- mkYesodData takes the @router@ (this is traditionally defined in a yesodroutes file, but we 34 | -- have opted to use the eDSL rowdy) and turns the router into data types for each handler 35 | -- function that is required. The other 1/2 of the routing magic takes your defined handler 36 | -- functions and gives yesod access to them, this can be found in 'src/Handler.hs'. 37 | -- N.B. A Handler loosely translates to endpoint in yesod-land 38 | mkYesodData "Foundation" router 39 | 40 | instance YesodBreadcrumbs Foundation where 41 | -- Takes the route that the user is currently on, and returns a tuple 42 | -- of the 'Text' that you want the label to display, and a previous 43 | -- breadcrumb route. 44 | breadcrumb 45 | :: Route Foundation -- ^ The route the user is visiting currently. 46 | -> Handler (Text, Maybe (Route Foundation)) 47 | breadcrumb HomeR = return ("Home", Nothing) 48 | breadcrumb LoginR = return ("Login", Just HomeR) 49 | breadcrumb LoginSigninR = return ("Signin", Just LoginR) 50 | breadcrumb SignupR = return ("Signup", Just HomeR) 51 | breadcrumb AccountCreateR = return ("Account Creation", Just HomeR) 52 | breadcrumb UserR = return ("User", Just HomeR) 53 | 54 | -- This is potentially useful for generically establishing http connections 55 | instance HasHttpManager Foundation where 56 | getHttpManager = appHttpManager 57 | 58 | instance Yesod Foundation where 59 | -- Controls the base of generated URLs. For more information on modifying, 60 | -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot 61 | approot :: Approot Foundation 62 | approot = ApprootRequest $ \app req -> 63 | case appRoot app of 64 | Nothing -> getApprootText guessApproot app req 65 | Just root -> root 66 | 67 | -- Store session data on the client in encrypted cookies, 68 | -- default session idle timeout is 120 minutes 69 | makeSessionBackend :: Foundation -> IO (Maybe SessionBackend) 70 | makeSessionBackend _ = Just <$> defaultClientSessionBackend 71 | 120 -- timeout in minutes 72 | "client_session_key.aes" 73 | 74 | -- Yesod Middleware allows you to run code before and after each handler function. 75 | -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. 76 | -- Some users may also want to add the defaultCsrfMiddleware, which: 77 | -- a) Sets a cookie with a CSRF token in it. 78 | -- b) Validates that incoming write requests include that token in either a header or POST parameter. 79 | -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware 80 | -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. 81 | yesodMiddleware handler = do 82 | addHeader "Vary" "Accept, Accept-Language" 83 | addHeader "X-XSS-Protection" "1; mode=block" 84 | authorizationCheck 85 | handler 86 | 87 | isAuthorized 88 | :: Route Foundation -- ^ The route the user is visiting. 89 | -> Bool -- ^ Whether or not this is a "write" request. 90 | -> Handler AuthResult 91 | -- Default to Authorized for now. 92 | isAuthorized _ _ = return Authorized 93 | 94 | -- What messages should be logged. Currently we just log everything, but eventually 95 | -- we will probably want to branch on environment and loglevel 96 | shouldLogIO :: Foundation -> Text -> LogLevel -> IO Bool 97 | shouldLogIO _ _ _ = return True 98 | 99 | makeLogger :: Foundation -> IO Logger 100 | makeLogger = return . appLogger 101 | 102 | -- Handler 103 | 104 | -- This is a convenience type that accomplishes two things: 105 | -- 1. It allows us to factor out some common boiler plate 106 | -- 2. It allows us to change DB implementations per monad in the future 107 | instance HasDB Handler where 108 | runDB :: DBT IO a -> Handler a 109 | runDB dbAction = do 110 | Foundation{..} <- getYesod 111 | liftIO $ ENT.withPool appPgPool dbAction 112 | 113 | instance MonadFail Handler where 114 | fail = liftIO . fail 115 | -------------------------------------------------------------------------------- /matchmaker.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 3.0 2 | name: matchmaker 3 | version: 0.0.1.0 4 | homepage: https://github.com/haskellfoundation/matchmaker#readme 5 | bug-reports: https://github.com/haskellfoundation/matchmaker/issues 6 | author: Hécate Moonlight & contributors 7 | maintainer: Hécate Moonlight & contributors 8 | license: Apache-2.0 9 | build-type: Simple 10 | extra-source-files: 11 | CHANGELOG.md 12 | LICENSE 13 | README.md 14 | 15 | source-repository head 16 | type: git 17 | location: https://github.com/haskellfoundation/matchmaker 18 | 19 | common common-extensions 20 | default-extensions: ConstraintKinds 21 | DataKinds 22 | DeriveAnyClass 23 | DeriveGeneric 24 | DerivingStrategies 25 | DerivingVia 26 | DuplicateRecordFields 27 | FlexibleContexts 28 | FlexibleInstances 29 | GeneralizedNewtypeDeriving 30 | InstanceSigs 31 | KindSignatures 32 | MultiParamTypeClasses 33 | NamedFieldPuns 34 | OverloadedStrings 35 | RankNTypes 36 | RecordWildCards 37 | ScopedTypeVariables 38 | StandaloneDeriving 39 | TemplateHaskell 40 | TypeApplications 41 | TypeOperators 42 | default-language: Haskell2010 43 | 44 | common common-ghc-options 45 | ghc-options: -Wall 46 | -Wcompat 47 | -Werror 48 | -Wno-deprecations 49 | -Widentities 50 | -Wincomplete-record-updates 51 | -Wincomplete-uni-patterns 52 | -Wpartial-fields 53 | -Wredundant-constraints 54 | -fhide-source-paths 55 | -Wno-unused-do-bind 56 | -fwrite-ide-info 57 | -hiedir=.hie 58 | -haddock 59 | -j 60 | 61 | common common-rts-options 62 | ghc-options: -rtsopts 63 | -threaded 64 | -with-rtsopts=-N 65 | 66 | library 67 | import: common-extensions 68 | import: common-ghc-options 69 | hs-source-dirs: 70 | src 71 | exposed-modules: 72 | DB 73 | DB.ContributorCall 74 | DB.Helpers 75 | DB.Organisation 76 | DB.Repository 77 | DB.User 78 | Environment 79 | Foundation 80 | Handler 81 | Handler.Home 82 | Handler.Login 83 | Handler.Login.Signin 84 | Handler.Signup 85 | Handler.Account.Create 86 | Handler.User 87 | ImportYesod 88 | Model.UserModel 89 | Server 90 | Templates 91 | Templates.Types 92 | Templates.Helpers 93 | Templates.Partials.FlashAlerts 94 | Web.FlashAlerts 95 | Web.Form 96 | Web.Form.Types 97 | Web.Helpers 98 | Web.Middleware 99 | Web.Router 100 | Web.Sessions 101 | Web.Sessions.Server 102 | Web.Sessions.Types 103 | Web.Types 104 | build-depends: 105 | aeson ^>= 1.5, 106 | base ^>= 4.14, 107 | base64-bytestring ^>= 1.2, 108 | colourista ^>= 0.1, 109 | containers ^>= 0.6.4, 110 | cryptonite ^>= 0.28, 111 | data-default-class ^>= 0.1, 112 | envparse ^>= 0.4, 113 | fast-logger ^>= 3.0.3, 114 | ginger ^>= 0.10, 115 | hashable ^>= 1.3, 116 | http-client ^>= 0.5.10, 117 | http-client-tls ^>= 0.3.5, 118 | http-types ^>= 0.12, 119 | monad-control ^>= 1.0, 120 | monad-logger ^>= 0.3, 121 | mtl ^>= 2.2.2, 122 | password ^>= 3.0, 123 | pg-entity ^>= 0.0, 124 | pg-transact ^>= 0.3.2, 125 | postgresql-simple ^>= 0.6, 126 | postgresql-simple-migration ^>= 0.1, 127 | relude ^>= 1.0, 128 | resource-pool ^>= 0.2, 129 | rowdy-yesod == 0.0.1.*, 130 | safe-exceptions ^>= 0.1, 131 | scotty ^>= 0.12, 132 | stm ^>= 2.5, 133 | string-interpolate ^>= 0.3, 134 | template-haskell ^>= 2.16, 135 | text ^>= 1.2, 136 | time ^>= 1.9, 137 | unordered-containers ^>= 0.2, 138 | uuid ^>= 1.3, 139 | validation-selective ^>= 0.1, 140 | vector ^>= 0.12.1, 141 | wai ^>= 3.2, 142 | wai-cors ^>= 0.2, 143 | wai-extra ^>= 3.1, 144 | wai-logger ^>= 2.3.6, 145 | wai-middleware-auth ^>= 0.2, 146 | wai-middleware-static ^>= 0.9, 147 | warp ^>= 3.3, 148 | yesod-core == 1.6.*, 149 | mixins: base hiding (Prelude) 150 | , relude ( Relude as Prelude 151 | , Relude.Unsafe 152 | , Relude.Monad 153 | ) 154 | 155 | executable matchmaker 156 | import: common-extensions 157 | import: common-ghc-options 158 | import: common-rts-options 159 | main-is: Main.hs 160 | hs-source-dirs: 161 | app 162 | build-depends: 163 | base 164 | , matchmaker 165 | , relude 166 | mixins: base hiding (Prelude) 167 | , relude ( Relude as Prelude 168 | , Relude.Unsafe 169 | , Relude.Monad 170 | ) 171 | 172 | test-suite matchmaker-test 173 | import: common-extensions 174 | import: common-ghc-options 175 | import: common-rts-options 176 | ghc-options: -Wdeprecations 177 | type: exitcode-stdio-1.0 178 | main-is: Main.hs 179 | hs-source-dirs: 180 | test 181 | build-depends: 182 | , base 183 | , hspec 184 | , hspec-expectations-lifted 185 | , hspec-pg-transact == 0.1.0.3 186 | , matchmaker 187 | , password 188 | , postgresql-simple 189 | , postgresql-simple-migration 190 | , relude 191 | , uuid 192 | , vector 193 | other-modules: 194 | DB.UserSpec 195 | DB.SpecHelpers 196 | DB.OrganisationSpec 197 | Web.AccountCreationSpec 198 | mixins: base hiding (Prelude) 199 | , relude ( Relude as Prelude 200 | , Relude.Unsafe) 201 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Format record definitions. This is disabled by default. 19 | # 20 | # You can control the layout of record fields. The only rules that can't be configured 21 | # are these: 22 | # 23 | # - "|" is always aligned with "=" 24 | # - "," in fields is always aligned with "{" 25 | # - "}" is likewise always aligned with "{" 26 | # 27 | # - records: 28 | # # How to format equals sign between type constructor and data constructor. 29 | # # Possible values: 30 | # # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor. 31 | # # - "indent N" -- insert a new line and N spaces from the beginning of the next line. 32 | # equals: "indent 2" 33 | # 34 | # # How to format first field of each record constructor. 35 | # # Possible values: 36 | # # - "same_line" -- "{" and first field goes on the same line as the data constructor. 37 | # # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor 38 | # first_field: "indent 2" 39 | # 40 | # # How many spaces to insert between the column with "," and the beginning of the comment in the next line. 41 | # field_comment: 2 42 | # 43 | # # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. 44 | # deriving: 2 45 | 46 | # Align the right hand side of some elements. This is quite conservative 47 | # and only applies to statements where each element occupies a single 48 | # line. All default to true. 49 | - simple_align: 50 | cases: true 51 | top_level_patterns: true 52 | records: true 53 | 54 | # Import cleanup 55 | - imports: 56 | # There are different ways we can align names and lists. 57 | # 58 | # - global: Align the import names and import list throughout the entire 59 | # file. 60 | # 61 | # - file: Like global, but don't add padding when there are no qualified 62 | # imports in the file. 63 | # 64 | # - group: Only align the imports per group (a group is formed by adjacent 65 | # import lines). 66 | # 67 | # - none: Do not perform any alignment. 68 | # 69 | # Default: global. 70 | align: none 71 | 72 | # The following options affect only import list alignment. 73 | # 74 | # List align has following options: 75 | # 76 | # - after_alias: Import list is aligned with end of import including 77 | # 'as' and 'hiding' keywords. 78 | # 79 | # > import qualified Data.List as List (concat, foldl, foldr, head, 80 | # > init, last, length) 81 | # 82 | # - with_alias: Import list is aligned with start of alias or hiding. 83 | # 84 | # > import qualified Data.List as List (concat, foldl, foldr, head, 85 | # > init, last, length) 86 | # 87 | # - with_module_name: Import list is aligned `list_padding` spaces after 88 | # the module name. 89 | # 90 | # > import qualified Data.List as List (concat, foldl, foldr, head, 91 | # init, last, length) 92 | # 93 | # This is mainly intended for use with `pad_module_names: false`. 94 | # 95 | # > import qualified Data.List as List (concat, foldl, foldr, head, 96 | # init, last, length, scanl, scanr, take, drop, 97 | # sort, nub) 98 | # 99 | # - new_line: Import list starts always on new line. 100 | # 101 | # > import qualified Data.List as List 102 | # > (concat, foldl, foldr, head, init, last, length) 103 | # 104 | # Default: after_alias 105 | list_align: after_alias 106 | 107 | # Right-pad the module names to align imports in a group: 108 | # 109 | # - true: a little more readable 110 | # 111 | # > import qualified Data.List as List (concat, foldl, foldr, 112 | # > init, last, length) 113 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 114 | # > init, last, length) 115 | # 116 | # - false: diff-safe 117 | # 118 | # > import qualified Data.List as List (concat, foldl, foldr, init, 119 | # > last, length) 120 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 121 | # > init, last, length) 122 | # 123 | # Default: true 124 | pad_module_names: false 125 | 126 | # Long list align style takes effect when import is too long. This is 127 | # determined by 'columns' setting. 128 | # 129 | # - inline: This option will put as much specs on same line as possible. 130 | # 131 | # - new_line: Import list will start on new line. 132 | # 133 | # - new_line_multiline: Import list will start on new line when it's 134 | # short enough to fit to single line. Otherwise it'll be multiline. 135 | # 136 | # - multiline: One line per import list entry. 137 | # Type with constructor list acts like single import. 138 | # 139 | # > import qualified Data.Map as M 140 | # > ( empty 141 | # > , singleton 142 | # > , ... 143 | # > , delete 144 | # > ) 145 | # 146 | # Default: inline 147 | long_list_align: inline 148 | 149 | # Align empty list (importing instances) 150 | # 151 | # Empty list align has following options 152 | # 153 | # - inherit: inherit list_align setting 154 | # 155 | # - right_after: () is right after the module name: 156 | # 157 | # > import Vector.Instances () 158 | # 159 | # Default: inherit 160 | empty_list_align: inherit 161 | 162 | # List padding determines indentation of import list on lines after import. 163 | # This option affects 'long_list_align'. 164 | # 165 | # - : constant value 166 | # 167 | # - module_name: align under start of module name. 168 | # Useful for 'file' and 'group' align settings. 169 | # 170 | # Default: 4 171 | list_padding: 4 172 | 173 | # Separate lists option affects formatting of import list for type 174 | # or class. The only difference is single space between type and list 175 | # of constructors, selectors and class functions. 176 | # 177 | # - true: There is single space between Foldable type and list of it's 178 | # functions. 179 | # 180 | # > import Data.Foldable (Foldable (fold, foldl, foldMap)) 181 | # 182 | # - false: There is no space between Foldable type and list of it's 183 | # functions. 184 | # 185 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 186 | # 187 | # Default: true 188 | separate_lists: true 189 | 190 | # Space surround option affects formatting of import lists on a single 191 | # line. The only difference is single space after the initial 192 | # parenthesis and a single space before the terminal parenthesis. 193 | # 194 | # - true: There is single space associated with the enclosing 195 | # parenthesis. 196 | # 197 | # > import Data.Foo ( foo ) 198 | # 199 | # - false: There is no space associated with the enclosing parenthesis 200 | # 201 | # > import Data.Foo (foo) 202 | # 203 | # Default: false 204 | space_surround: false 205 | 206 | # Language pragmas 207 | - language_pragmas: 208 | # We can generate different styles of language pragma lists. 209 | # 210 | # - vertical: Vertical-spaced language pragmas, one per line. 211 | # 212 | # - compact: A more compact style. 213 | # 214 | # - compact_line: Similar to compact, but wrap each line with 215 | # `{-#LANGUAGE #-}'. 216 | # 217 | # Default: vertical. 218 | style: vertical 219 | 220 | # Align affects alignment of closing pragma brackets. 221 | # 222 | # - true: Brackets are aligned in same column. 223 | # 224 | # - false: Brackets are not aligned together. There is only one space 225 | # between actual import and closing bracket. 226 | # 227 | # Default: true 228 | align: true 229 | 230 | # stylish-haskell can detect redundancy of some language pragmas. If this 231 | # is set to true, it will remove those redundant pragmas. Default: true. 232 | remove_redundant: false 233 | 234 | # Language prefix to be used for pragma declaration, this allows you to 235 | # use other options non case-sensitive like "language" or "Language". 236 | # If a non correct String is provided, it will default to: LANGUAGE. 237 | language_prefix: LANGUAGE 238 | 239 | # Replace tabs by spaces. This is disabled by default. 240 | # - tabs: 241 | # # Number of spaces to use for each tab. Default: 8, as specified by the 242 | # # Haskell report. 243 | # spaces: 8 244 | 245 | # Remove trailing whitespace 246 | - trailing_whitespace: {} 247 | 248 | # Squash multiple spaces between the left and right hand sides of some 249 | # elements into single spaces. Basically, this undoes the effect of 250 | # simple_align but is a bit less conservative. 251 | # - squash: {} 252 | 253 | # A common setting is the number of columns (parts of) code will be wrapped 254 | # to. Different steps take this into account. 255 | # 256 | # Set this to null to disable all line wrapping. 257 | # 258 | # Default: 80. 259 | columns: 80 260 | 261 | # By default, line endings are converted according to the OS. You can override 262 | # preferred format here. 263 | # 264 | # - native: Native newline format. CRLF on Windows, LF on other OSes. 265 | # 266 | # - lf: Convert to LF ("\n"). 267 | # 268 | # - crlf: Convert to CRLF ("\r\n"). 269 | # 270 | # Default: native. 271 | newline: native 272 | 273 | # Sometimes, language extensions are specified in a cabal file or from the 274 | # command line instead of using language pragmas in the file. stylish-haskell 275 | # needs to be aware of these, so it can parse the file correctly. 276 | # 277 | # No language extensions are enabled by default. 278 | # language_extensions: 279 | # - TemplateHaskell 280 | # - QuasiQuotes 281 | 282 | # Attempt to find the cabal file in ancestors of the current directory, and 283 | # parse options (currently only language extensions) from that. 284 | # 285 | # Default: true 286 | cabal: true 287 | -------------------------------------------------------------------------------- /cabal.project.freeze: -------------------------------------------------------------------------------- 1 | active-repositories: hackage.haskell.org:merge 2 | constraints: any.Cabal ==3.2.1.0, 3 | any.HUnit ==1.6.2.0, 4 | any.Only ==0.1, 5 | any.QuickCheck ==2.14.2, 6 | QuickCheck -old-random +templatehaskell, 7 | any.StateVar ==1.2.2, 8 | any.adjunctions ==4.4, 9 | any.aeson ==1.5.6.0, 10 | aeson -bytestring-builder -cffi -developer -fast, 11 | any.aeson-pretty ==0.8.8, 12 | aeson-pretty -lib-only, 13 | any.ansi-terminal ==0.11, 14 | ansi-terminal -example, 15 | any.ansi-wl-pprint ==0.6.9, 16 | ansi-wl-pprint -example, 17 | any.appar ==0.1.8, 18 | any.array ==0.5.4.0, 19 | any.asn1-encoding ==0.9.6, 20 | any.asn1-parse ==0.9.5, 21 | any.asn1-types ==0.3.4, 22 | any.assoc ==1.0.2, 23 | any.async ==2.2.3, 24 | async -bench, 25 | any.attoparsec ==0.14.1, 26 | attoparsec -developer, 27 | any.auto-update ==0.1.6, 28 | any.base ==4.14.1.0, 29 | any.base-compat ==0.12.0, 30 | any.base-compat-batteries ==0.12.0, 31 | any.base-orphans ==0.8.5, 32 | any.base-unicode-symbols ==0.2.4.2, 33 | base-unicode-symbols +base-4-8 -old-base, 34 | any.base16-bytestring ==1.0.1.0, 35 | any.base64 ==0.4.2.3, 36 | any.base64-bytestring ==1.2.1.0, 37 | any.basement ==0.0.12, 38 | any.bifunctors ==5.5.11, 39 | bifunctors +semigroups +tagged, 40 | any.binary ==0.8.8.0, 41 | any.blaze-builder ==0.4.2.1, 42 | any.blaze-html ==0.9.1.2, 43 | any.blaze-markup ==0.8.2.8, 44 | any.bsb-http-chunked ==0.0.0.4, 45 | any.byteable ==0.1.1, 46 | any.byteorder ==1.0.4, 47 | any.bytestring ==0.10.12.0, 48 | any.bytestring-builder ==0.10.8.2.0, 49 | bytestring-builder +bytestring_has_builder, 50 | any.cabal-doctest ==1.0.8, 51 | any.call-stack ==0.4.0, 52 | any.case-insensitive ==1.2.1.0, 53 | any.cereal ==0.5.8.1, 54 | cereal -bytestring-builder, 55 | any.cipher-aes ==0.2.11, 56 | cipher-aes +support_aesni, 57 | any.clientsession ==0.9.1.2, 58 | clientsession -test, 59 | any.clock ==0.8.2, 60 | clock -llvm, 61 | any.cmdargs ==0.10.21, 62 | cmdargs +quotation -testprog, 63 | any.colour ==2.3.6, 64 | any.colourista ==0.1.0.1, 65 | any.comonad ==5.0.8, 66 | comonad +containers +distributive +indexed-traversable, 67 | any.concise ==0.1.0.1, 68 | any.conduit ==1.3.4.1, 69 | any.conduit-extra ==1.3.5, 70 | any.connection ==0.3.1, 71 | any.containers ==0.6.2.1 || ==0.6.5.1, 72 | any.contravariant ==1.5.5, 73 | contravariant +semigroups +statevar +tagged, 74 | any.cookie ==0.4.5, 75 | any.cprng-aes ==0.6.1, 76 | any.crypto-api ==0.13.3, 77 | crypto-api -all_cpolys, 78 | any.crypto-cipher-types ==0.0.9, 79 | any.crypto-random ==0.0.9, 80 | any.cryptohash ==0.11.9, 81 | any.cryptohash-md5 ==0.11.100.1, 82 | any.cryptohash-sha1 ==0.11.100.1, 83 | any.cryptonite ==0.28, 84 | cryptonite -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq -support_pclmuldq +support_rdrand -support_sse +use_target_attributes, 85 | any.data-default ==0.7.1.1, 86 | any.data-default-class ==0.1.2.0, 87 | any.data-default-instances-containers ==0.0.1, 88 | any.data-default-instances-dlist ==0.0.1, 89 | any.data-default-instances-old-locale ==0.0.1, 90 | any.data-fix ==0.3.2, 91 | any.deepseq ==1.4.4.0, 92 | any.directory ==1.3.6.0, 93 | any.distributive ==0.6.2.1, 94 | distributive +semigroups +tagged, 95 | any.dlist ==1.0, 96 | dlist -werror, 97 | any.easy-file ==0.2.2, 98 | any.entropy ==0.4.1.6, 99 | entropy -halvm, 100 | any.envparse ==0.4.1, 101 | any.errors ==2.3.0, 102 | any.exceptions ==0.10.4, 103 | any.expiring-cache-map ==0.0.6.1, 104 | any.fail ==4.9.0.0, 105 | any.fast-logger ==3.0.5, 106 | any.file-embed ==0.0.15.0, 107 | any.filepath ==1.4.2.1, 108 | any.free ==5.1.7, 109 | any.generic-monoid ==0.1.0.1, 110 | any.ghc-boot-th ==8.10.4, 111 | any.ghc-byteorder ==4.11.0.0.10, 112 | any.ghc-prim ==0.6.1, 113 | any.ginger ==0.10.2.0, 114 | any.githash ==0.1.6.1, 115 | any.happy ==1.20.0, 116 | any.hashable ==1.3.3.0, 117 | hashable +integer-gmp -random-initial-seed, 118 | any.haskell-src-exts ==1.23.1, 119 | any.haskell-src-meta ==0.8.7, 120 | any.hoauth2 ==1.16.0, 121 | hoauth2 -test, 122 | any.hourglass ==0.2.12, 123 | any.hsc2hs ==0.68.7, 124 | hsc2hs -in-ghc-tree, 125 | any.hspec ==2.8.3, 126 | any.hspec-core ==2.8.3, 127 | any.hspec-discover ==2.8.3, 128 | any.hspec-expectations ==0.8.2, 129 | any.hspec-expectations-lifted ==0.10.0, 130 | any.hspec-pg-transact ==0.1.0.3, 131 | any.http-client ==0.5.14, 132 | http-client +network-uri, 133 | any.http-client-tls ==0.3.5.3, 134 | any.http-conduit ==2.3.8, 135 | http-conduit +aeson, 136 | any.http-date ==0.0.11, 137 | any.http-reverse-proxy ==0.6.0, 138 | any.http-types ==0.12.3, 139 | any.http2 ==3.0.2, 140 | http2 -devel -doc -h2spec, 141 | any.indexed-traversable ==0.1.1, 142 | any.indexed-traversable-instances ==0.1, 143 | any.integer-gmp ==1.0.3.0, 144 | any.integer-logarithms ==1.0.3.1, 145 | integer-logarithms -check-bounds +integer-gmp, 146 | any.invariant ==0.5.4, 147 | any.iproute ==1.7.11, 148 | any.jose ==0.8.4.1, 149 | jose -demos, 150 | any.kan-extensions ==5.2.3, 151 | any.lens ==5.0.1, 152 | lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, 153 | any.libyaml ==0.1.2, 154 | libyaml -no-unicode -system-libyaml, 155 | any.lifted-base ==0.2.3.12, 156 | any.memory ==0.16.0, 157 | memory +support_basement +support_bytestring +support_deepseq +support_foundation, 158 | any.microlens ==0.4.12.0, 159 | any.mime-types ==0.1.0.9, 160 | any.monad-control ==1.0.3.1, 161 | any.monad-logger ==0.3.36, 162 | monad-logger +template_haskell, 163 | any.monad-loops ==0.4.3, 164 | monad-loops +base4, 165 | any.monad-time ==0.3.1.0, 166 | any.mono-traversable ==1.0.15.1, 167 | any.mtl ==2.2.2, 168 | any.nats ==1.1.2, 169 | nats +binary +hashable +template-haskell, 170 | any.network ==3.1.2.2, 171 | network -devel, 172 | any.network-byte-order ==0.1.6, 173 | any.network-info ==0.2.0.10, 174 | any.network-uri ==2.6.4.1, 175 | any.old-locale ==1.0.0.7, 176 | any.old-time ==1.1.0.3, 177 | any.optparse-applicative ==0.16.1.0, 178 | optparse-applicative +process, 179 | any.optparse-simple ==0.1.1.4, 180 | optparse-simple -build-example, 181 | any.parallel ==3.2.2.0, 182 | any.parsec ==3.1.14.0, 183 | any.password ==3.0.0.0, 184 | any.password-types ==1.0.0.0, 185 | any.path-pieces ==0.2.1, 186 | any.pem ==0.2.4, 187 | any.pg-entity ==0.0.1.0, 188 | any.pg-transact ==0.3.2.0, 189 | any.port-utils ==0.2.1.0, 190 | any.postgres-options ==0.2.0.0, 191 | any.postgresql-libpq ==0.9.4.3, 192 | postgresql-libpq -use-pkg-config, 193 | any.postgresql-simple ==0.6.4, 194 | any.postgresql-simple-migration ==0.1.15.0, 195 | any.pretty ==1.1.3.6, 196 | any.primitive ==0.7.2.0, 197 | any.process ==1.6.9.0, 198 | any.profunctors ==5.6.2, 199 | any.psqueues ==0.2.7.2, 200 | any.quickcheck-instances ==0.3.25.2, 201 | quickcheck-instances -bytestring-builder, 202 | any.quickcheck-io ==0.2.0, 203 | any.random ==1.2.0, 204 | any.reflection ==2.1.6, 205 | reflection -slow +template-haskell, 206 | any.regex-base ==0.94.0.1, 207 | any.regex-compat ==0.95.2.1, 208 | any.regex-posix ==0.96.0.1, 209 | regex-posix -_regex-posix-clib, 210 | any.regex-tdfa ==1.3.1.1, 211 | regex-tdfa -force-o2, 212 | any.relude ==1.0.0.1, 213 | any.resource-pool ==0.2.3.2, 214 | resource-pool -developer, 215 | any.resourcet ==1.2.4.3, 216 | any.rowdy ==0.0.1.0, 217 | any.rowdy-yesod ==0.0.1.1, 218 | any.rts ==1.0, 219 | any.safe ==0.3.19, 220 | any.safe-exceptions ==0.1.7.2, 221 | any.scientific ==0.3.7.0, 222 | scientific -bytestring-builder -integer-simple, 223 | any.scotty ==0.12, 224 | any.securemem ==0.1.10, 225 | any.selective ==0.4.2, 226 | any.semigroupoids ==5.3.5, 227 | semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, 228 | any.semigroups ==0.19.2, 229 | semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, 230 | any.setenv ==0.1.1.3, 231 | any.shakespeare ==2.0.25, 232 | shakespeare -test_coffee -test_export -test_roy, 233 | any.simple-sendfile ==0.2.30, 234 | simple-sendfile +allow-bsd, 235 | any.skein ==1.0.9.4, 236 | skein -big-endian -force-endianness -reference, 237 | any.socks ==0.6.1, 238 | any.split ==0.2.3.4, 239 | any.splitmix ==0.1.0.3, 240 | splitmix -optimised-mixer, 241 | any.stm ==2.5.0.0, 242 | any.stm-chans ==3.0.0.4, 243 | any.streaming-commons ==0.2.2.1, 244 | streaming-commons -use-bytestring-builder, 245 | any.strict ==0.4.0.1, 246 | strict +assoc, 247 | any.string-interpolate ==0.3.1.1, 248 | string-interpolate -bytestring-builder -extended-benchmarks -text-builder, 249 | any.syb ==0.7.2.1, 250 | any.tagged ==0.8.6.1, 251 | tagged +deepseq +transformers, 252 | any.template-haskell ==2.16.0.0, 253 | any.temporary ==1.3, 254 | any.text ==1.2.4.1 || ==1.2.5.0, 255 | text -developer, 256 | any.text-conversions ==0.3.1, 257 | any.text-manipulate ==0.3.0.0, 258 | any.text-short ==0.1.3, 259 | text-short -asserts, 260 | any.tf-random ==0.5, 261 | any.th-abstraction ==0.4.3.0, 262 | any.th-compat ==0.1.3, 263 | any.th-expand-syns ==0.4.9.0, 264 | any.th-lift ==0.8.2, 265 | any.th-lift-instances ==0.1.18, 266 | any.th-orphans ==0.13.12, 267 | any.th-reify-many ==0.1.10, 268 | any.these ==1.1.1.1, 269 | these +assoc, 270 | any.time ==1.9.3, 271 | any.time-compat ==1.9.6.1, 272 | time-compat -old-locale, 273 | any.time-manager ==0.0.0, 274 | any.tls ==1.5.5, 275 | tls +compat -hans +network, 276 | any.tmp-postgres ==1.34.1.0, 277 | any.transformers ==0.5.6.2, 278 | any.transformers-base ==0.4.6, 279 | transformers-base +orphaninstances, 280 | any.transformers-compat ==0.7, 281 | transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, 282 | any.typed-process ==0.2.6.1, 283 | any.unix ==2.7.2.2, 284 | any.unix-compat ==0.5.3, 285 | unix-compat -old-time, 286 | any.unix-time ==0.4.7, 287 | any.unliftio ==0.2.20, 288 | any.unliftio-core ==0.2.0.1, 289 | any.unordered-containers ==0.2.14.0, 290 | unordered-containers -debug, 291 | any.uri-bytestring ==0.3.3.1, 292 | uri-bytestring -lib-werror, 293 | any.uri-bytestring-aeson ==0.1.0.8, 294 | any.utf8-string ==1.0.2, 295 | any.uuid ==1.3.15, 296 | any.uuid-types ==1.0.5, 297 | any.validation-selective ==0.1.0.1, 298 | any.vault ==0.3.1.5, 299 | vault +useghc, 300 | any.vector ==0.12.3.0, 301 | vector +boundschecks -internalchecks -unsafechecks -wall, 302 | any.vector-algorithms ==0.8.0.4, 303 | vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks, 304 | any.void ==0.7.3, 305 | void -safe, 306 | any.wai ==3.2.3, 307 | any.wai-app-static ==3.1.7.2, 308 | wai-app-static -print, 309 | any.wai-cors ==0.2.7, 310 | any.wai-extra ==3.1.6, 311 | wai-extra -build-example, 312 | any.wai-logger ==2.3.6, 313 | any.wai-middleware-auth ==0.2.5.1, 314 | any.wai-middleware-static ==0.9.0, 315 | any.warp ==3.3.17, 316 | warp +allow-sendfilefd -network-bytestring -warp-debug, 317 | any.word8 ==0.1.3, 318 | any.x509 ==1.7.5, 319 | any.x509-store ==1.6.7, 320 | any.x509-system ==1.6.6, 321 | any.x509-validation ==1.6.11, 322 | any.yaml ==0.11.5.0, 323 | yaml +no-examples +no-exe, 324 | any.yesod-core ==1.6.21.0, 325 | any.zlib ==0.6.2.3, 326 | zlib -bundled-c-zlib -non-blocking-ffi -pkg-config 327 | index-state: hackage.haskell.org 2021-09-06T17:46:21Z 328 | --------------------------------------------------------------------------------