├── .gitignore ├── CONTRIBUTIONS.md ├── LICENSE ├── README.md ├── SPEC.md ├── ServantOpaleye ├── .gitignore ├── CHANGELOG.md ├── DB.hs ├── Domain │ ├── Base.hs │ ├── BaseTypes.hs │ └── Tenant.hs ├── DomainApi.hs ├── LICENSE.md ├── README.md ├── Setup.hs ├── benchmark │ └── Main.hs ├── db │ ├── generate_schema_spy.sh │ ├── schema.sql │ └── schema_spy │ │ ├── anomalies.html │ │ ├── columns.byAuto.html │ │ ├── columns.byColumn.html │ │ ├── columns.byDefault.html │ │ ├── columns.byNulls.html │ │ ├── columns.bySize.html │ │ ├── columns.byTable.html │ │ ├── columns.byType.html │ │ ├── constraints.html │ │ ├── deletionOrder.txt │ │ ├── diagrams │ │ ├── addresses.1degree.dot │ │ ├── addresses.1degree.png │ │ ├── addresses.2degrees.dot │ │ ├── addresses.2degrees.png │ │ ├── audit_logs.1degree.dot │ │ ├── audit_logs.1degree.png │ │ ├── audit_logs.2degrees.dot │ │ ├── audit_logs.2degrees.png │ │ ├── customers.1degree.dot │ │ ├── customers.1degree.png │ │ ├── customers.2degrees.dot │ │ ├── customers.2degrees.png │ │ ├── line_items.1degree.dot │ │ ├── line_items.1degree.png │ │ ├── line_items.2degrees.dot │ │ ├── line_items.2degrees.png │ │ ├── orders.1degree.dot │ │ ├── orders.1degree.png │ │ ├── orders.2degrees.dot │ │ ├── orders.2degrees.png │ │ ├── photos.1degree.dot │ │ ├── photos.1degree.png │ │ ├── photos.2degrees.dot │ │ ├── photos.2degrees.png │ │ ├── products.1degree.dot │ │ ├── products.1degree.png │ │ ├── products.2degrees.dot │ │ ├── products.2degrees.png │ │ ├── roles.1degree.dot │ │ ├── roles.1degree.png │ │ ├── roles.2degrees.dot │ │ ├── roles.2degrees.png │ │ ├── summary │ │ │ ├── relationships.real.compact.dot │ │ │ ├── relationships.real.compact.png │ │ │ ├── relationships.real.large.dot │ │ │ └── relationships.real.large.png │ │ ├── taxes.1degree.dot │ │ ├── taxes.1degree.png │ │ ├── taxes.2degrees.dot │ │ ├── taxes.2degrees.png │ │ ├── tenants.1degree.dot │ │ ├── tenants.1degree.png │ │ ├── users.1degree.dot │ │ ├── users.1degree.png │ │ ├── users.2degrees.dot │ │ ├── users.2degrees.png │ │ ├── variants.1degree.dot │ │ ├── variants.1degree.png │ │ ├── variants.2degrees.dot │ │ └── variants.2degrees.png │ │ ├── images │ │ ├── background.gif │ │ ├── tabLeft.gif │ │ └── tabRight.gif │ │ ├── index.html │ │ ├── insertionOrder.txt │ │ ├── jquery.js │ │ ├── relationships.html │ │ ├── schemaSpy.css │ │ ├── schemaSpy.js │ │ ├── servant_opaleye.public.xml │ │ ├── tables │ │ ├── addresses.html │ │ ├── audit_logs.html │ │ ├── customers.html │ │ ├── line_items.html │ │ ├── orders.html │ │ ├── photos.html │ │ ├── products.html │ │ ├── roles.html │ │ ├── taxes.html │ │ ├── tenants.html │ │ ├── users.html │ │ └── variants.html │ │ └── utilities.html ├── executable │ └── Main.hs ├── library │ └── Example.hs ├── package.yaml ├── stack.yaml └── test-suite │ └── Main.hs ├── ServantPersistent ├── LICENSE ├── ServantPersistent.cabal ├── Setup.hs ├── app │ └── Main.hs ├── src │ ├── API.hs │ ├── Auth.hs │ ├── DBTypes.hs │ ├── Domain │ │ ├── Tenant.hs │ │ └── User.hs │ ├── Environ.hs │ ├── Models.hs │ ├── Operation.hs │ ├── Server.hs │ ├── Types.hs │ └── Updater.hs ├── stack.yaml └── test │ └── Spec.hs ├── SpockOpaleye ├── LICENSE ├── Setup.hs ├── SpockOpaleye.cabal ├── app │ └── Main.hs ├── src │ ├── CryptoDef.hs │ ├── DataTypes.hs │ ├── JsonInstances.hs │ ├── Lib.hs │ ├── OpaleyeDef.hs │ ├── RoleAPi.hs │ ├── TenantApi.hs │ ├── UserApi.hs │ └── Validations.hs ├── stack.yaml ├── test │ └── Spec.hs └── tips.txt ├── UI ├── ReflexFRP │ ├── mockLoginPage │ │ ├── README.org │ │ ├── mockAPI │ │ │ ├── Setup.hs │ │ │ ├── mockAPI.cabal │ │ │ ├── src │ │ │ │ └── MockAPI.hs │ │ │ └── stack.yaml │ │ ├── mockClient │ │ │ ├── Main.hs │ │ │ ├── Setup.hs │ │ │ ├── assets │ │ │ │ ├── bootstrap │ │ │ │ │ ├── css │ │ │ │ │ │ └── bootstrap.min.css │ │ │ │ │ └── js │ │ │ │ │ │ └── bootstrap.min.js │ │ │ │ ├── css │ │ │ │ │ ├── Login-Form-Clean.css │ │ │ │ │ └── styles.css │ │ │ │ ├── fonts │ │ │ │ │ ├── ionicons.eot │ │ │ │ │ ├── ionicons.min.css │ │ │ │ │ ├── ionicons.svg │ │ │ │ │ ├── ionicons.ttf │ │ │ │ │ └── ionicons.woff │ │ │ │ ├── html │ │ │ │ │ └── index.html │ │ │ │ └── js │ │ │ │ │ └── jquery.min.js │ │ │ ├── deploy.sh │ │ │ ├── js │ │ │ │ ├── all.min.js │ │ │ │ ├── index.html │ │ │ │ └── manifest.webapp │ │ │ ├── mockLoginPage.cabal │ │ │ ├── stack-ghcjs.yaml │ │ │ └── stack.yaml │ │ └── mockServer │ │ │ ├── Main.hs │ │ │ ├── Setup.hs │ │ │ ├── mockServer.cabal │ │ │ └── stack.yaml │ └── starterApp │ │ ├── LICENSE │ │ ├── Main.hs │ │ ├── README.org │ │ ├── Setup.hs │ │ ├── deploy.sh │ │ ├── stack-ghcjs.yaml │ │ ├── stack.yaml │ │ └── starterApp.cabal └── comparison.org ├── doc ├── .gitignore ├── Makefile ├── _templates │ └── footer.html ├── conf.py ├── docs │ ├── framework │ │ ├── basic-crud.rst │ │ ├── deploying.rst │ │ ├── index.rst │ │ ├── migrations.rst │ │ └── strict-validations.rst │ ├── opaleye │ │ ├── advanced-db-mapping.rst │ │ ├── basic-db-mapping.rst │ │ ├── code │ │ │ ├── instant-gratification.hs │ │ │ ├── opaleye-enums-handling.hs │ │ │ ├── opaleye-products-tenants-join.hs │ │ │ ├── opaleye-products-with-json-properties.hs │ │ │ ├── opaleye-readonly.hs │ │ │ ├── opaleye-select-basic-with-records.hs │ │ │ ├── opaleye-select-basic.hs │ │ │ ├── opaleye-select-custom-datatype-row.hs │ │ │ ├── opaleye-select-custom-datatype.hs │ │ │ ├── opaleye-select-with-condition.hs │ │ │ ├── opaleye-select-with-records-and-restrict.hs │ │ │ └── opaleye-tenants-and-products.hs │ │ ├── inserting-rows.rst │ │ ├── instant-gratification.rst │ │ ├── opaleye.rst │ │ ├── selecting-rows.rst │ │ └── updating-rows.rst │ ├── reflex │ │ ├── a-server-client-architecture.rst │ │ ├── getting-started.rst │ │ ├── img │ │ │ └── starterApp.png │ │ ├── outline.rst │ │ └── reflex.rst │ └── relational-record │ │ ├── advanced-db-mapping.rst │ │ ├── advanced-workflow.rst │ │ ├── basic-db-mapping.rst │ │ ├── basic-workflow.rst │ │ ├── instant-gratification.rst │ │ ├── relational-record-intro.rst │ │ ├── relational-record.rst │ │ └── summary-conclusion.rst ├── hakyll │ ├── README.md │ ├── _site │ │ ├── about.html │ │ ├── archive.html │ │ ├── contact.html │ │ ├── css │ │ │ └── default.css │ │ ├── images │ │ │ └── haskell-logo.png │ │ ├── index.html │ │ └── posts │ │ │ ├── db-mappings-opaleye.html │ │ │ ├── db-mappings-overview.html │ │ │ └── overview.html │ ├── about.rst │ ├── contact.markdown │ ├── css │ │ └── default.css │ ├── db-mappings.md │ ├── doc.cabal │ ├── images │ │ └── haskell-logo.png │ ├── includes │ │ └── db-mappings │ │ │ ├── DB.hs │ │ │ └── schema.sql │ ├── index.html │ ├── posts │ │ ├── db-mappings-opaleye.markdown │ │ ├── db-mappings-overview.md │ │ ├── opaleye │ │ │ └── db-mappings.markdown │ │ └── overview.markdown │ ├── site.hs │ ├── stack.yaml │ └── templates │ │ ├── archive.html │ │ ├── default.html │ │ ├── post-list.html │ │ └── post.html └── index.rst ├── json-api-spec.apib ├── json-api-spec.html ├── skeleton ├── LICENSE ├── Setup.hs ├── app │ └── Main.hs ├── skeleton.cabal ├── src │ ├── Domain │ │ ├── Auth.hs │ │ ├── Photo.hs │ │ ├── Product.hs │ │ ├── Role.hs │ │ ├── Tenant.hs │ │ ├── Types.hs │ │ └── User.hs │ ├── Import.hs │ └── Lib.hs ├── stack.yaml └── test │ └── Spec.hs └── ui-mockups ├── assets ├── bootstrap │ ├── css │ │ └── bootstrap.min.css │ ├── fonts │ │ ├── glyphicons-halflings-regular.eot │ │ ├── glyphicons-halflings-regular.svg │ │ ├── glyphicons-halflings-regular.ttf │ │ ├── glyphicons-halflings-regular.woff │ │ └── glyphicons-halflings-regular.woff2 │ └── js │ │ └── bootstrap.min.js ├── css │ ├── Login-Form-Clean.css │ ├── styles.css │ └── styles.min.css ├── fonts │ ├── ionicons.eot │ ├── ionicons.min.css │ ├── ionicons.svg │ ├── ionicons.ttf │ └── ionicons.woff └── js │ └── jquery.min.js ├── index.html ├── login.html ├── role-edit-with-errors.html ├── role-edit.html ├── roles.html ├── roles ├── edit.html └── index.html └── ui-mockups.bsdesign /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | _build/ 20 | cabal.project.local 21 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 vacationlabs 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /SPEC.md: -------------------------------------------------------------------------------- 1 | # What are we building 2 | 3 | A typical shopping-cart (ecommerce) webapp. But it isn't the entire app with all bells and whistles. Just a few features - enough to uncover a "Minimum Viable Architecture" (that leverages the Haskell type-system to good use). 4 | 5 | # Things to cover in the spec 6 | 7 | | Requirement / Case / Scenaro | How is it covered in the spec? | 8 | | --- | --- | 9 | | Authentication | Peristen login cookie which needs to be periodically refershed for a session token (which expires) | 10 | | Type-safe authorization | `roles` table, which has a list of permissions. Permissions are pre-defined by the app, but the tenant can group any permission to define a new role | 11 | | Siged-out (not logged-in) operations | End-customer visiting the storefront | 12 | | Signed-in operations for users with different priveleges | Editing various fields in a product can require different set of permissions | 13 | | Domain-level operations that require DB transactions | (a) Creating & editing a product with variants, (b) changing any record in the DB along with audit logs | 14 | | Complex web-form with validations and error messages | (a) Product creation/editing (b) Image uploads | 15 | | Searching the app's core data based on user-input | (a) Admin-side product listing page (b) End-customer facing product listing page | 16 | | Sending out plain text & HTML emails with attachments | Tenant activation email. We can attach a logo inline for use by the HTML part of the email | 17 | | ENUM support | `tenant_status`, `user_status`, `product_type`, `weight_unit` | 18 | | JSONB support | `audit_logs.changes` and `products.propertes` | 19 | | Array support | `roles.permissions` | 20 | | 1:1 association | Tenant:Account-owner | 21 | | 1:many associations | (a) Product:variant, (b) Product:Photo, (c) Variant:Photo | 22 | | many:many associations | `users_roles` join-through table | 23 | | Fields in response JSON should depend in incoming request | `/products/:id?fields=` [discussion](https://github.com/vacationlabs/haskell-webapps/issues/10) | 24 | | Redis caching at object-level | Individual product JSONs should be cached in Redis **TODO: Discussion** | 25 | | Redis caching at page-level | Final HTML of individual product pages should be cached in Redis **TODO: Discussion** | 26 | | Audit logs | `audit_logs` table | 27 | | How to deal with runtime errors in production | [Integrate with existing error management tools](https://github.com/vacationlabs/haskell-webapps/issues/13) 28 | | Unit tests | **TODO** | 29 | | Controller tests | **TODO** | 30 | | Integration tests | **TODO** | 31 | | Static assets during development | **TODO** | 32 | | Deployment | **TODO** | 33 | 34 | # Domain-Level API to be implemented in Phase 1 35 | 36 | * Tenant creation 37 | * User creation 38 | * Tenant activation along with assigning owner 39 | * Simple email+password based authentication 40 | * Get list of products, with search, sort, and pagination 41 | * Get single product details (fixed/pre-decided JSON response) 42 | * Get single product details with fields specified in the request (variable JSON response, depending upon the request) 43 | * Only privileged users can get access to the following fields: inventory count, cost price 44 | * Create a new product 45 | * Requires "product admin" privileges 46 | * Upload & auto-crop images to various geometries 47 | * Modify an existing product 48 | * Tags 49 | * Variants 50 | * Images 51 | * Only 52 | 53 | -------------------------------------------------------------------------------- /ServantOpaleye/.gitignore: -------------------------------------------------------------------------------- 1 | # Stack uses this directory as scratch space. 2 | /.stack-work/ 3 | # Stack generates the Cabal file from `package.yaml` through hpack. 4 | /*.cabal 5 | -------------------------------------------------------------------------------- /ServantOpaleye/CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change log 2 | 3 | ServantOpaleye uses [Semantic Versioning][]. 4 | The change log is available through the [releases on GitHub][]. 5 | 6 | [Semantic Versioning]: http://semver.org/spec/v2.0.0.html 7 | [releases on GitHub]: https://github.com/githubuser/ServantOpaleye/releases 8 | -------------------------------------------------------------------------------- /ServantOpaleye/Domain/Base.hs: -------------------------------------------------------------------------------- 1 | -- TODO: This can act as my custom prelude 2 | module Domain.Base( 3 | module Opaleye 4 | ,module DB 5 | ,module Domain.BaseTypes 6 | ) where 7 | 8 | import qualified Data.Text as T 9 | import Opaleye (Query) 10 | import Domain.BaseTypes 11 | import DB 12 | -------------------------------------------------------------------------------- /ServantOpaleye/Domain/BaseTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE TypeSynonymInstances #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | 7 | module Domain.BaseTypes where 8 | import Control.Monad.Identity 9 | import DB 10 | import Data.Text 11 | import Data.Time 12 | import Database.PostgreSQL.Simple (Connection) 13 | import Control.Monad.Reader (ReaderT, ask) 14 | import Control.Lens 15 | 16 | data AppConfig = AppConfig { 17 | appConfigDbPool :: Connection 18 | } 19 | 20 | $(makeLensesWith abbreviatedFields ''AppConfig) 21 | 22 | -- TODO: Figure out the right monad-transformed stack for the domain API. We'll have to do the following: 23 | -- * DB operations 24 | -- * Logging 25 | -- * Redis operations, potentitally 26 | type AppM = ReaderT AppConfig IO 27 | 28 | class Monad m => HasDbConn m where 29 | askDbConnection :: m Connection 30 | 31 | instance HasDbConn (AppM) where 32 | askDbConnection = fmap appConfigDbPool ask 33 | 34 | -- data TenantWithStatus status = Tenant 35 | -------------------------------------------------------------------------------- /ServantOpaleye/Domain/Tenant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE GADTs #-} 3 | {-# LANGUAGE KindSignatures #-} 4 | {-# LANGUAGE ViewPatterns #-} 5 | 6 | module Domain.Tenant where 7 | 8 | import Domain.Base 9 | import Opaleye 10 | import Data.Text hiding (head) 11 | import Control.Monad.IO.Class (liftIO) 12 | import Control.Lens 13 | import qualified Database.PostgreSQL.Simple as PGS 14 | import Control.Monad.Reader (runReaderT) 15 | import Data.String.Conv 16 | import Control.Monad.Catch 17 | import Database.PostgreSQL.Simple.Errors 18 | import Database.PostgreSQL.Simple (SqlError) 19 | -- 20 | -- Tenant creation 21 | -- 22 | 23 | data TenantCreationError = DuplicateBackofficeDomainError Text deriving Show 24 | 25 | 26 | -- NOTE: Going with simple data-types for now (i.e. not creating different 27 | -- data-types for Active/Inactive tenant). Let's see how this pans out. 28 | 29 | -- tenantPgToApp :: TenantPGRead -> Tenant 30 | -- tenantPgToApp pgTenant = 31 | 32 | createTenant :: NewTenant -> AppM (Either TenantCreationError Tenant) 33 | createTenant newTenant = do 34 | conn <- askDbConnection 35 | liftIO $ catchViolation catcher (createTenant_ conn) 36 | where 37 | createTenant_ conn = (Right . head) <$> runInsertManyReturning conn tenantTable [newTenantToPg newTenant] id 38 | 39 | -- TODO: Figure out how to write this in a pattern-matching style 40 | catcher _ (UniqueViolation s) | s == toS "idx_unique_tenants_backoffice_domain" = return $ Left $ DuplicateBackofficeDomainError $ newTenant ^. backofficeDomain 41 | catcher sqlError _ = throwM sqlError 42 | 43 | -- activateTenant :: TenantId -> AppM (Tenant) 44 | -- activateTenant tenantId@(TenantId tid) = do 45 | -- conn <- askDbConnection 46 | -- liftIO $ do 47 | -- _ <- runUpdate conn tenantTable 48 | -- (\tenant -> tenant & status .~ TenantActive) 49 | -- (\tenant -> (tenant ^. key .== pgInt8 tid)) 50 | -- head <$> runQuery conn (tenantById tenantId) 51 | 52 | 53 | -- 54 | -- main 55 | -- 56 | testHarness = do 57 | conn <- PGS.connect PGS.defaultConnectInfo{ 58 | PGS.connectUser = "servant_opaleye" 59 | ,PGS.connectPassword = "123" 60 | ,PGS.connectDatabase = "servant_opaleye" 61 | } 62 | let newTenant = Tenant{ 63 | tenantKey = () 64 | ,tenantCreatedAt = () 65 | ,tenantUpdatedAt = () 66 | ,tenantStatus = () 67 | ,tenantOwnerId = Nothing 68 | ,tenantName = toS "Vacation Lab4" 69 | ,tenantBackofficeDomain = toS "http://app.vacatinlabs.com/vl4" 70 | } 71 | runReaderT (createTenant newTenant) AppConfig{appConfigDbPool=conn} 72 | -- where 73 | -- action = do 74 | -- conn <- askDbConnection 75 | -- liftIO $ (runQuery conn (tenantById $ TenantId 3) :: IO [Tenant]) 76 | -------------------------------------------------------------------------------- /ServantOpaleye/LICENSE.md: -------------------------------------------------------------------------------- 1 | [The MIT License (MIT)][] 2 | 3 | Copyright (c) 2016 Author name here 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies 9 | of the Software, and to permit persons to whom the Software is furnished to do 10 | so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | 23 | [The MIT License (MIT)]: https://opensource.org/licenses/MIT 24 | -------------------------------------------------------------------------------- /ServantOpaleye/README.md: -------------------------------------------------------------------------------- 1 | # [ServantOpaleye][] 2 | 3 | Thanks for starting a project with Haskeleton! If you haven't heard of it 4 | before, I suggest reading the introductory blog post. You can find it here: 5 | . 6 | 7 | Before you get started, there are a few things that this template couldn't 8 | provide for you. You should: 9 | 10 | - Add a synopsis to `package.yaml`. It should be a short (one sentence) 11 | explanation of your project. 12 | 13 | - Add a description to `package.yaml`. This can be whatever you want it to 14 | be. 15 | 16 | - Add a category to `package.yaml`. A list of categories is available on 17 | Hackage at . 18 | 19 | - Rename `library/Example.hs` to whatever you want your top-level module to 20 | be called. Typically this is the same as your package name but in 21 | `CamelCase` instead of `kebab-case`. 22 | 23 | - Don't forget to rename the reference to it in 24 | `executable/Main.hs`! 25 | 26 | - If you are on an older version of Stack (<1.0.4), delete `package.yaml` and 27 | remove `/*.cabal` from your `.gitignore`. 28 | 29 | Once you've done that, start working on your project with the Stack commands 30 | you know and love. 31 | 32 | ``` sh 33 | # Build the project. 34 | stack build 35 | 36 | # Run the test suite. 37 | stack test 38 | 39 | # Run the benchmarks. 40 | stack bench 41 | 42 | # Generate documentation. 43 | stack haddock 44 | ``` 45 | 46 | Thanks again, and happy hacking! 47 | 48 | [ServantOpaleye]: https://github.com/githubuser/ServantOpaleye 49 | -------------------------------------------------------------------------------- /ServantOpaleye/Setup.hs: -------------------------------------------------------------------------------- 1 | -- This script is used to build and install your package. Typically you don't 2 | -- need to change it. The Cabal documentation has more information about this 3 | -- file: . 4 | import qualified Distribution.Simple 5 | 6 | main :: IO () 7 | main = Distribution.Simple.defaultMain 8 | -------------------------------------------------------------------------------- /ServantOpaleye/benchmark/Main.hs: -------------------------------------------------------------------------------- 1 | -- You can benchmark your code quickly and effectively with Criterion. See its 2 | -- website for help: . 3 | import Criterion.Main 4 | 5 | main :: IO () 6 | main = defaultMain [bench "const" (whnf const ())] 7 | -------------------------------------------------------------------------------- /ServantOpaleye/db/generate_schema_spy.sh: -------------------------------------------------------------------------------- 1 | java -jar ~/Downloads/schemaSpy_5.0.0.jar -t pgsql -host localhost -u servant_opaleye -p servant_opaleye -o schema_spy -db servant_opaleye -dp ~/Downloads/postgresql-9.4.1211.jar -s public 2 | -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/anomalies.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | SchemaSpy - servant_opaleye.public - Anomalies 6 | 7 | 8 | 9 | 10 | 11 | 12 |
13 | 23 |
24 |
25 | 26 | 27 | 28 | 29 | 30 |
SchemaSpy Analysis of servant_opaleye.public - AnomaliesGenerated by
SchemaSpy
31 | 32 | 33 | 34 | 35 |
SourceForge.net
Things that might not be 'quite right' about your schema: 36 |
37 | 49 | 52 |
53 |
54 |
    55 |
  • 56 | Columns whose name and type imply a relationship to another table's primary key: 57 |
    Anomaly not detected

    • 58 |
  • 59 | Tables without indexes: 60 |
    Anomaly not detected

    • 61 |
  • 62 | Columns that are flagged as both 'nullable' and 'must be unique': 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 |
    Column
    tenants.owner_id
    75 | 1 instance of anomaly detected

    • 76 |
  • 77 | Tables that contain a single column:
    Anomaly not detected

    • 78 |
  • 79 | Tables with incrementing column names, potentially indicating denormalization: 80 |
    Anomaly not detected

    • 81 |
  • 82 | Columns whose default value is the word 'NULL' or 'null', but the SQL NULL value may have been intended: 83 |
    Anomaly not detected

    • 84 |
85 |
86 | 87 | 88 | -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/deletionOrder.txt: -------------------------------------------------------------------------------- 1 | photos 2 | audit_logs 3 | roles 4 | variants 5 | products 6 | users 7 | tenants 8 | -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/addresses.1degree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/addresses.1degree.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/addresses.2degrees.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/addresses.2degrees.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/audit_logs.1degree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/audit_logs.1degree.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/audit_logs.2degrees.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/audit_logs.2degrees.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/customers.1degree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/customers.1degree.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/customers.2degrees.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/customers.2degrees.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/line_items.1degree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/line_items.1degree.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/line_items.2degrees.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/line_items.2degrees.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/orders.1degree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/orders.1degree.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/orders.2degrees.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/orders.2degrees.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/photos.1degree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/photos.1degree.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/photos.2degrees.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/photos.2degrees.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/products.1degree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/products.1degree.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/products.2degrees.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/products.2degrees.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/roles.1degree.dot: -------------------------------------------------------------------------------- 1 | // dot 2.38.0 on Mac OS X 10.11.3 2 | // SchemaSpy rev 590 3 | digraph "oneDegreeRelationshipsDiagram" { 4 | graph [ 5 | rankdir="RL" 6 | bgcolor="#f7f7f7" 7 | label="\nGenerated by SchemaSpy" 8 | labeljust="l" 9 | nodesep="0.18" 10 | ranksep="0.46" 11 | fontname="Helvetica" 12 | fontsize="11" 13 | ]; 14 | node [ 15 | fontname="Helvetica" 16 | fontsize="11" 17 | shape="plaintext" 18 | ]; 19 | edge [ 20 | arrowsize="0.8" 21 | ]; 22 | "roles":"tenant_id":w -> "tenants":"id":e [arrowhead=none dir=back arrowtail=teeodot]; 23 | "roles" [ 24 | label=< 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 |
roles
idserial[10]
tenant_idint4[10]
nametext[2147483647]
permissions_text[2147483647]
created_attimestamptz[35,6]
updated_attimestamptz[35,6]
< 10 rows0 >
> 35 | URL="roles.html" 36 | tooltip="roles" 37 | ]; 38 | "tenants" [ 39 | label=< 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 |
tenants
id
created_at
updated_at
name
status
owner_id
backoffice_domain
< 10 rows6 >
> 51 | URL="tenants.html" 52 | tooltip="tenants" 53 | ]; 54 | } 55 | -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/roles.1degree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/roles.1degree.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/roles.2degrees.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/roles.2degrees.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/summary/relationships.real.compact.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/summary/relationships.real.compact.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/summary/relationships.real.large.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/summary/relationships.real.large.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/taxes.1degree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/taxes.1degree.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/taxes.2degrees.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/taxes.2degrees.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/tenants.1degree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/tenants.1degree.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/users.1degree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/users.1degree.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/users.2degrees.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/users.2degrees.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/variants.1degree.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/variants.1degree.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/diagrams/variants.2degrees.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/diagrams/variants.2degrees.png -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/images/background.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/images/background.gif -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/images/tabLeft.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/images/tabLeft.gif -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/images/tabRight.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ServantOpaleye/db/schema_spy/images/tabRight.gif -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/insertionOrder.txt: -------------------------------------------------------------------------------- 1 | tenants 2 | users 3 | products 4 | variants 5 | roles 6 | audit_logs 7 | photos 8 | -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/schemaSpy.js: -------------------------------------------------------------------------------- 1 | // table-based pages are expected to set 'table' to their name 2 | var table = null; 3 | 4 | // sync target's visibility with the state of checkbox 5 | function sync(cb, target) { 6 | var checked = cb.attr('checked'); 7 | var displayed = target.css('display') != 'none'; 8 | if (checked != displayed) { 9 | if (checked) 10 | target.show(); 11 | else 12 | target.hide(); 13 | } 14 | } 15 | 16 | // sync target's visibility with the inverse of the state of checkbox 17 | function unsync(cb, target) { 18 | var checked = cb.attr('checked'); 19 | var displayed = target.css('display') != 'none'; 20 | if (checked == displayed) { 21 | if (checked) 22 | target.hide(); 23 | else 24 | target.show(); 25 | } 26 | } 27 | 28 | // associate the state of checkbox with the visibility of target 29 | function associate(cb, target) { 30 | sync(cb, target); 31 | cb.click(function() { 32 | sync(cb, target); 33 | }); 34 | } 35 | 36 | // select the appropriate image based on the options selected 37 | function syncImage() { 38 | var implied = $('#implied').attr('checked'); 39 | 40 | $('.diagram').hide(); 41 | 42 | if (table) { 43 | if (implied && $('#impliedTwoDegreesImg').size() > 0) { 44 | $('#impliedTwoDegreesImg').show(); 45 | } else { 46 | var oneDegree = $('#oneDegree').attr('checked'); 47 | 48 | if (oneDegree || $('#twoDegreesImg').size() == 0) { 49 | $('#oneDegreeImg').show(); 50 | } else { 51 | $('#twoDegreesImg').show(); 52 | } 53 | } 54 | } else { 55 | var showNonKeys = $('#showNonKeys').attr('checked'); 56 | 57 | if (implied) { 58 | if (showNonKeys && $('#impliedLargeImg').size() > 0) { 59 | $('#impliedLargeImg').show(); 60 | } else if ($('#impliedCompactImg').size() > 0) { 61 | $('#impliedCompactImg').show(); 62 | } else { 63 | $('#realCompactImg').show(); 64 | } 65 | } else { 66 | if (showNonKeys && $('#realLargeImg').size() > 0) { 67 | $('#realLargeImg').show(); 68 | } else { 69 | $('#realCompactImg').show(); 70 | } 71 | } 72 | } 73 | } 74 | 75 | // our 'ready' handler makes the page consistent 76 | $(function(){ 77 | associate($('#implied'), $('.impliedRelationship')); 78 | associate($('#showComments'), $('.comment')); 79 | associate($('#showLegend'), $('.legend')); 80 | associate($('#showRelatedCols'), $('.relatedKey')); 81 | associate($('#showConstNames'), $('.constraint')); 82 | 83 | syncImage(); 84 | $('#implied,#oneDegree,#twoDegrees,#showNonKeys').click(function() { 85 | syncImage(); 86 | }); 87 | 88 | unsync($('#implied'), $('.degrees')); 89 | $('#implied').click(function() { 90 | unsync($('#implied'), $('.degrees')); 91 | }); 92 | 93 | unsync($('#removeImpliedOrphans'), $('.impliedNotOrphan')); 94 | $('#removeImpliedOrphans').click(function() { 95 | unsync($('#removeImpliedOrphans'), $('.impliedNotOrphan')); 96 | }); 97 | }); 98 | -------------------------------------------------------------------------------- /ServantOpaleye/db/schema_spy/utilities.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | SchemaSpy - servant_opaleye.public - Utility Tables 6 | 7 | 8 | 9 | 10 | 11 | 12 |
13 | 24 |
25 |
26 | 27 | 28 | 29 | 30 | 31 |
SchemaSpy Analysis of servant_opaleye.public - Utility TablesGenerated by
SchemaSpy
32 | 33 | 36 | 72 |
34 | Generated by SchemaSpy on Mon Oct 10 16:44 IST 2016 35 | 37 | 38 | 39 | 40 | 41 | 42 | 52 |
Legend:SourceForge.net
43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 |
Primary key columns
Columns with indexes
Excluded column relationships
Dashed lines show implied relationships
< n > number of related tables
51 |
53 |
54 | 66 | 69 |
70 |   71 |
73 |
74 | 75 | 76 |
77 | 78 | 79 | -------------------------------------------------------------------------------- /ServantOpaleye/executable/Main.hs: -------------------------------------------------------------------------------- 1 | -- It is generally a good idea to keep all your business logic in your library 2 | -- and only use it in the executable. Doing so allows others to use what you 3 | -- wrote in their libraries. 4 | import qualified Example 5 | 6 | main :: IO () 7 | main = Example.main 8 | -------------------------------------------------------------------------------- /ServantOpaleye/library/Example.hs: -------------------------------------------------------------------------------- 1 | -- | An example module. 2 | module Example (main) where 3 | 4 | -- | An example function. 5 | main :: IO () 6 | main = return () 7 | -------------------------------------------------------------------------------- /ServantOpaleye/package.yaml: -------------------------------------------------------------------------------- 1 | # This YAML file describes your package. Stack will automatically generate a 2 | # Cabal file when you run `stack build`. See the hpack website for help with 3 | # this file: . 4 | benchmarks: 5 | ServantOpaleye-benchmarks: 6 | dependencies: 7 | - base 8 | - ServantOpaleye 9 | - criterion 10 | ghc-options: 11 | - -rtsopts 12 | - -threaded 13 | - -with-rtsopts=-N 14 | main: Main.hs 15 | source-dirs: benchmark 16 | category: Other 17 | description: ServantOpaleye is a new Haskeleton package. 18 | executables: 19 | ServantOpaleye: 20 | dependencies: 21 | - base 22 | - ServantOpaleye 23 | ghc-options: 24 | - -rtsopts 25 | - -threaded 26 | - -with-rtsopts=-N 27 | main: Main.hs 28 | source-dirs: executable 29 | extra-source-files: 30 | - CHANGELOG.md 31 | - LICENSE.md 32 | - package.yaml 33 | - README.md 34 | - stack.yaml 35 | ghc-options: -Wall 36 | github: githubuser/ServantOpaleye 37 | library: 38 | exposed-modules: 39 | - DB 40 | - DomainApi 41 | dependencies: 42 | - base 43 | - text 44 | - mtl 45 | - opaleye >= 0.5.1.1 46 | - product-profunctors 47 | - time 48 | - postgresql-simple 49 | - lens 50 | - transformers 51 | - bytestring 52 | - string-conv 53 | - data-default 54 | - exceptions 55 | # source-dirs: library 56 | license: MIT 57 | maintainer: Author name here 58 | name: ServantOpaleye 59 | synopsis: A new Haskeleton package. 60 | tests: 61 | ServantOpaleye-test-suite: 62 | dependencies: 63 | - base 64 | - ServantOpaleye 65 | - tasty 66 | - tasty-hspec 67 | ghc-options: 68 | - -rtsopts 69 | - -threaded 70 | - -with-rtsopts=-N 71 | main: Main.hs 72 | source-dirs: test-suite 73 | version: '0.0.0' 74 | -------------------------------------------------------------------------------- /ServantOpaleye/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-6.12 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [opaleye-0.5.1.1] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /ServantOpaleye/test-suite/Main.hs: -------------------------------------------------------------------------------- 1 | -- Tasty makes it easy to test your code. It is a test framework that can 2 | -- combine many different types of tests into one suite. See its website for 3 | -- help: . 4 | import qualified Test.Tasty 5 | -- Hspec is one of the providers for Tasty. It provides a nice syntax for 6 | -- writing tests. Its website has more info: . 7 | import Test.Tasty.Hspec 8 | 9 | main :: IO () 10 | main = do 11 | test <- testSpec "ServantOpaleye" spec 12 | Test.Tasty.defaultMain test 13 | 14 | spec :: Spec 15 | spec = parallel $ do 16 | it "is trivially true" $ do 17 | True `shouldBe` True -------------------------------------------------------------------------------- /ServantPersistent/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /ServantPersistent/ServantPersistent.cabal: -------------------------------------------------------------------------------- 1 | name: ServantPersistent 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/githubuser/ServantPersistent#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2016 Author name here 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: API 19 | , Types 20 | , Auth 21 | , Server 22 | , Environ 23 | , Models 24 | , Domain.Tenant 25 | , Domain.User 26 | , Updater 27 | , DBTypes 28 | , Operation 29 | ghc-options: -Wall 30 | build-depends: base >= 4.7 && < 5 31 | , aeson 32 | , servant-server 33 | , servant 34 | , servant-auth-cookie 35 | , cereal 36 | , wai 37 | , ghc-prim 38 | , text 39 | , time 40 | , bytestring 41 | , warp 42 | , mtl 43 | , persistent 44 | , persistent-template 45 | , persistent-postgresql 46 | , monad-logger 47 | , exceptions 48 | , lens 49 | , unordered-containers 50 | , containers 51 | , transformers 52 | , data-default 53 | default-language: Haskell2010 54 | 55 | executable ServantPersistent-exe 56 | hs-source-dirs: app 57 | main-is: Main.hs 58 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 59 | build-depends: base 60 | , ServantPersistent 61 | , servant-server 62 | , servant 63 | , servant-auth-cookie 64 | , persistent-postgresql 65 | , monad-logger 66 | , wai 67 | , warp 68 | , cryptonite 69 | , data-default 70 | default-language: Haskell2010 71 | 72 | test-suite ServantPersistent-test 73 | type: exitcode-stdio-1.0 74 | hs-source-dirs: test 75 | main-is: Spec.hs 76 | build-depends: base 77 | , ServantPersistent 78 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 79 | default-language: Haskell2010 80 | 81 | source-repository head 82 | type: git 83 | location: https://github.com/githubuser/ServantPersistent 84 | -------------------------------------------------------------------------------- /ServantPersistent/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ServantPersistent/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import API 5 | import Auth 6 | import Data.Proxy 7 | import Crypto.Random 8 | import Servant 9 | import Network.Wai 10 | import Servant.API.Experimental.Auth 11 | import Servant.Server.Experimental.Auth.Cookie 12 | import Servant.Server.Experimental.Auth 13 | import Types 14 | import Data.Default 15 | import Network.Wai.Handler.Warp 16 | import Server 17 | import Models 18 | import Control.Monad.Logger 19 | import Database.Persist.Postgresql 20 | 21 | 22 | main :: IO () 23 | main = do 24 | randomSource <- mkRandomSource drgNew 10000 25 | serverKey <- mkServerKey 256 Nothing 26 | pool <- makePool 27 | flip runSqlPool pool $ runMigration migrateAll 28 | let config = Config { authSettings = (def {acsCookieFlags = ["HttpOnly"]}) 29 | , randomSource = randomSource 30 | , serverKey = serverKey 31 | , environment = Devel 32 | , dbPool = pool 33 | } 34 | run 8080 $ serveWithContext (testAPI) 35 | ((cookieAuthHandler def serverKey) :. EmptyContext) 36 | (testServer config) 37 | 38 | connStr = "host=localhost dbname=perservant user=test password=test port=5432" 39 | 40 | makePool = runStdoutLoggingT $ createPostgresqlPool connStr 1 41 | -------------------------------------------------------------------------------- /ServantPersistent/src/API.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE LiberalTypeSynonyms #-} 4 | module API 5 | where 6 | 7 | import Servant 8 | import Data.ByteString 9 | 10 | import Auth 11 | import DBTypes 12 | import Types 13 | 14 | type ProductID = Int 15 | type ActivationRequest = () 16 | type ActivationResponse = () 17 | type Product = () 18 | 19 | type TenantAPI = 20 | "new" :> ReqBody '[JSON] TenantInput 21 | :> Post '[JSON] (Headers '[Header "location" String] TenantID) 22 | :<|> Capture "id" TenantID :> Get '[JSON] TenantOutput 23 | -- :<|> Capture "id" TenantID :> "activate" :> ReqBody '[JSON] ActivationRequest :> Post '[JSON] ActivationResponse 24 | 25 | type SessionAPI = 26 | "new" :> ReqBody '[JSON] LoginForm :> Post '[JSON] (Headers '[Header "set-cookie" ByteString] ()) 27 | -- :<|> "refresh" :> ReqBody '[JSON] LoginForm :> Post '[JSON] (Headers '[Header "set-cookie" ByteString] ()) 28 | -- :<|> "destroy" :> ReqBody '[JSON] LoginForm :> Post '[JSON] (Headers '[Header "set-cookie" ByteString] ()) 29 | 30 | type ProductAPI = 31 | Capture "id" ProductID :> Get '[JSON] Product 32 | :<|> Get '[JSON] [Product] 33 | 34 | type API = "tenants" :> TenantAPI 35 | :<|> "session" :> SessionAPI 36 | :<|> "products" :> ProtectEndpoints ProductAPI 37 | 38 | api :: Proxy API 39 | api = Proxy 40 | 41 | -------------------------------------------------------------------------------- /ServantPersistent/src/Auth.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | module Auth 11 | where 12 | 13 | import Servant 14 | import Network.Wai 15 | import Servant.Server.Experimental.Auth.Cookie 16 | import Servant.Server.Experimental.Auth 17 | import Control.Monad.Catch (try) 18 | import Types 19 | 20 | type instance AuthCookieData = Either CookieError Session 21 | 22 | type family ProtectEndpoints a where 23 | ProtectEndpoints (a :<|> b) = (ProtectEndpoints a) :<|> (ProtectEndpoints b) 24 | ProtectEndpoints (a :> b) = a :> ProtectEndpoints b 25 | ProtectEndpoints a = AppAuth :> a 26 | 27 | type AppAuth = AuthProtect "cookie-auth" 28 | 29 | instance HasLink sub => HasLink (AppAuth :> sub) where 30 | type MkLink (AppAuth :> sub) = MkLink sub 31 | toLink _ = toLink (Proxy :: Proxy sub) 32 | 33 | cookieAuthHandler :: AuthCookieSettings -> ServerKey -> AuthHandler Request (Either CookieError Session) 34 | cookieAuthHandler authSettings serverKey = mkAuthHandler $ \request -> do 35 | result <- try $ getSession authSettings serverKey request 36 | case result :: Either AuthCookieException (Maybe Session) of 37 | Left a -> return $ Left $ AuthError a 38 | Right a -> return $ maybe (Left NotPresent) Right a 39 | 40 | 41 | validateLogin :: LoginForm -> App Bool 42 | validateLogin _ = return True 43 | 44 | -------------------------------------------------------------------------------- /ServantPersistent/src/Domain/Tenant.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Domain.Tenant 3 | where 4 | 5 | import Control.Lens 6 | import Data.Time 7 | import Database.Persist 8 | import Control.Monad.IO.Class 9 | import Data.Text (Text) 10 | import Data.ByteString (ByteString) 11 | import Models 12 | import Types 13 | import Updater 14 | import DBTypes 15 | import Operation 16 | 17 | dbCreateTenant :: TenantInput -> App (Maybe TenantID) 18 | dbCreateTenant ti = runDb $ do 19 | time <- liftIO $ getCurrentTime 20 | let dbt = DBTenant { _dBTenantName = ti ^. name 21 | , _dBTenantBackofficeDomain = ti ^. backofficeDomain 22 | , _dBTenantOwnerId = Nothing 23 | , _dBTenantStatus = NewT 24 | , _dBTenantCreatedAt = time 25 | , _dBTenantUpdatedAt = time 26 | } 27 | insertUnique dbt 28 | 29 | 30 | dbGetTenant :: TenantID -> App (Maybe Tenant) 31 | dbGetTenant = runDb . get 32 | 33 | dbUpdateTenant :: TenantUpdater -> TenantID -> OperationT App (Either DBError ()) 34 | dbUpdateTenant tu id = requirePermission (EditTenant id) >> (runDb $ do 35 | time <- liftIO $ getCurrentTime 36 | oldTenant' <- get id 37 | case oldTenant' of 38 | Nothing -> return $ Left $ TenantNotFound id 39 | Just oldTenant -> Right <$> replace id (set updatedAt time $ runUpdate tu oldTenant)) 40 | 41 | 42 | encode = undefined 43 | 44 | decode = undefined 45 | 46 | activateTenant :: UserID -> ByteString -> App () 47 | activateTenant uid actkey = runDb $ do 48 | let (Activation tid _) = decode actkey 49 | time <- liftIO $ getCurrentTime 50 | update tid [ DBTenantOwnerId =. Just uid 51 | , DBTenantStatus =. ActiveT 52 | , DBTenantUpdatedAt =. time 53 | ] 54 | -------------------------------------------------------------------------------- /ServantPersistent/src/Domain/User.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Domain.User 3 | where 4 | 5 | import Control.Lens 6 | import Data.Time 7 | import Database.Persist 8 | import Control.Monad.IO.Class 9 | import Control.Monad.Except 10 | import Data.Default 11 | import Models 12 | import Types 13 | import Updater 14 | import DBTypes 15 | import Operation 16 | 17 | dbCreateUser :: UserInput -> App (Either UserCreationError UserID) 18 | dbCreateUser u = runExceptT $ do 19 | time <- liftIO getCurrentTime 20 | let dbu = DBUser { _dBUserFirstName = view firstName u 21 | , _dBUserLastName = view lastName u 22 | , _dBUserTenantID = view tenantID u 23 | , _dBUserUsername = view username u 24 | , _dBUserPassword = view password u 25 | , _dBUserEmail = view email u 26 | , _dBUserPhone = view phone u 27 | , _dBUserStatus = InactiveU 28 | , _dBUserCreatedAt = time 29 | , _dBUserUpdatedAt = time 30 | } 31 | result <- runDb $ insertUnique dbu 32 | case result of 33 | Just a -> return a 34 | Nothing -> throwError $ UserExists (view username u) 35 | 36 | dbUpdateUser :: UserID -> UserUpdater -> OperationT App (Either DBError ()) 37 | dbUpdateUser id uu = requirePermission (EditUser id) >> (runDb $ do 38 | time <- liftIO $ getCurrentTime 39 | oldUser' <- get id 40 | case oldUser' of 41 | Nothing -> return $ Left $ UserNotFound id 42 | Just oldUser -> Right <$> replace id (set updatedAt time $ runUpdate uu oldUser)) 43 | 44 | dbGetUser :: UserID -> OperationT App (Either DBError User) 45 | dbGetUser uid = runExceptT $ do 46 | dbu <- ExceptT $ maybe (Left $ UserNotFound uid) 47 | Right 48 | <$> (runDb $ get uid) 49 | let u = UserB { _userFirstName = view firstName dbu 50 | , _userLastName = view lastName dbu 51 | , _userTenantID = view tenantID dbu 52 | , _userUsername = view username dbu 53 | , _userPassword = () 54 | , _userEmail = view email dbu 55 | , _userPhone = view phone dbu 56 | , _userStatus = InactiveU 57 | , _userRole = def 58 | , _userUserID = uid 59 | } 60 | return u 61 | -------------------------------------------------------------------------------- /ServantPersistent/src/Environ.hs: -------------------------------------------------------------------------------- 1 | module Environ 2 | where 3 | 4 | import Control.Monad.Reader 5 | import Types 6 | 7 | inEnvironment :: Environment -> App () -> App () 8 | inEnvironment e m = do 9 | env <- asks environment 10 | when (e == env) m 11 | 12 | inDevel :: App () -> App () 13 | inDevel = inEnvironment Devel 14 | -------------------------------------------------------------------------------- /ServantPersistent/src/Models.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE TypeFamilies #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | {-# LANGUAGE FlexibleContexts #-} 10 | {-# LANGUAGE TypeFamilyDependencies #-} 11 | {-# LANGUAGE TypeInType #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | module Models 14 | where 15 | 16 | import Database.Persist.Sql 17 | import Database.Persist.TH 18 | import Data.Time.Clock 19 | import Data.Text 20 | import Control.Monad.IO.Class 21 | import Control.Monad.Reader 22 | import Types 23 | 24 | share [mkPersist sqlSettings { mpsGenerateLenses = True }, mkMigrate "migrateAll"] [persistLowerCase| 25 | DBTenant json 26 | name Text 27 | backofficeDomain Text 28 | ownerId DBUserId Maybe 29 | status TenantStatus 30 | createdAt UTCTime 31 | updatedAt UTCTime 32 | UniqueBackofficeDomain backofficeDomain 33 | 34 | DBUser 35 | firstName Text 36 | lastName Text 37 | tenantID DBTenantId 38 | username Text 39 | password Text 40 | status UserStatus 41 | email Text 42 | phone Text 43 | createdAt UTCTime 44 | updatedAt UTCTime 45 | UniqueUsername username 46 | UniqueEmail email 47 | |] 48 | 49 | 50 | instance HasTimestamp DBTenant where 51 | createdAt = dBTenantCreatedAt 52 | updatedAt = dBTenantUpdatedAt 53 | instance HasTimestamp DBUser where 54 | createdAt = dBUserCreatedAt 55 | updatedAt = dBUserUpdatedAt 56 | 57 | instance HasName DBTenant where 58 | name = dBTenantName 59 | instance HasBackofficeDomain DBTenant where 60 | backofficeDomain = dBTenantBackofficeDomain 61 | 62 | instance HasHumanName DBUser where 63 | firstName = dBUserFirstName 64 | lastName = dBUserLastName 65 | instance HasContactDetails DBUser where 66 | email = dBUserEmail 67 | phone = dBUserPhone 68 | instance HasUsername DBUser where 69 | username = dBUserUsername 70 | instance HasPassword DBUser where 71 | password = dBUserPassword 72 | 73 | runDb :: (MonadReader Config m, MonadIO m) => SqlPersistT IO b -> m b 74 | runDb query = do 75 | pool <- asks dbPool 76 | liftIO $ runSqlPool query pool 77 | -------------------------------------------------------------------------------- /ServantPersistent/src/Operation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE StandaloneDeriving #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | module Operation 9 | ( OperationT 10 | , Permission(..) 11 | , requirePermission 12 | , runOperation 13 | ) where 14 | import Prelude hiding (null, filter) 15 | import Data.Set 16 | import Data.Text (Text) 17 | import Control.Monad.Trans 18 | import Control.Monad.Reader 19 | import Control.Monad.State 20 | import Control.Monad.Except 21 | import Control.Applicative 22 | import Control.Monad.Writer.Strict 23 | import qualified Database.Persist as DB 24 | import Control.Lens 25 | import Types 26 | import DBTypes 27 | import Models 28 | 29 | data Permission = EditUser UserID 30 | | EditTenant TenantID 31 | | ViewUser UserID 32 | deriving (Eq,Ord,Show) 33 | 34 | data PermissionError = Requires (Set Permission) 35 | 36 | newtype OperationT m a = Op { unsafeRunOp :: WriterT (Set Permission) m a } 37 | deriving (Functor, Applicative, Monad, Alternative, MonadPlus, Foldable, MonadFix, MonadTrans, MonadIO) 38 | 39 | deriving instance (MonadReader r m) => MonadReader r (OperationT m) 40 | deriving instance (MonadState s m) => MonadState s (OperationT m) 41 | deriving instance (MonadError e m) => MonadError e (OperationT m) 42 | 43 | requirePermission :: Monad m => Permission -> OperationT m () 44 | requirePermission = Op . tell . singleton 45 | 46 | runOperation :: OperationT App a -> User -> ExceptT PermissionError App a 47 | runOperation op u@(UserB{_userRole=role}) = do 48 | (a,s) <- lift $ runWriterT $ unsafeRunOp op 49 | let go s (EditUserDetails) = 50 | fromList <$> 51 | filterM (\case (EditUser uid) -> hasTenant uid (_userTenantID u) 52 | _ -> return False) 53 | (toList s) 54 | go s (EditTenantDetails) = 55 | fromList <$> 56 | filterM (\case (EditTenant tid) -> return $ tid == (_userTenantID u) 57 | _ -> return False) 58 | (toList s) 59 | go s _ = return s 60 | s' <- lift $ foldM go s (roleCapabilities role) 61 | if null s' 62 | then return a 63 | else throwError $ Requires s' 64 | 65 | hasTenant :: UserID -> TenantID -> App Bool 66 | hasTenant uid tid = runDb $ do 67 | tid' <- fmap _dBUserTenantID <$> DB.get uid 68 | case tid' of 69 | Nothing -> return False 70 | Just tid' -> return (tid == tid') 71 | -------------------------------------------------------------------------------- /ServantPersistent/src/Server.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE FlexibleContexts #-} 8 | module Server 9 | where 10 | 11 | import Servant 12 | import Data.ByteString 13 | import Control.Monad.Except 14 | import Control.Monad.Reader 15 | import Servant.Server.Experimental.Auth.Cookie 16 | import Auth 17 | import Types 18 | import API 19 | import Environ 20 | import Domain.Tenant 21 | import DBTypes 22 | 23 | 24 | type TestAPI = API 25 | 26 | testAPI :: Proxy TestAPI 27 | testAPI = Proxy 28 | 29 | newTenant :: TenantInput -> App (Headers '[Header "location" String] TenantID) 30 | newTenant ti = do 31 | result <- dbCreateTenant ti 32 | case result of 33 | Nothing -> throwError $ err400 { errBody = "Tenant already exists" } 34 | Just id -> return $ addHeader (show id) id 35 | 36 | getTenant :: TenantID -> App TenantOutput 37 | getTenant tid = do 38 | result <- dbGetTenant tid 39 | case result of 40 | Nothing -> throwError $ err404 { errBody = "Tenant doesn't exist" } 41 | Just t -> return t 42 | 43 | newSession :: LoginForm -> App (Headers '[Header "set-cookie" ByteString] ()) 44 | newSession login = do 45 | Config{..} <- ask 46 | loginValid <- validateLogin login 47 | inDevel $ liftIO $ print login 48 | let session = Session (loginUsername login) 49 | if loginValid 50 | then addSession authSettings randomSource serverKey session () 51 | else throwError $ err400 { errBody = "Invalid login." } 52 | 53 | testSessionHandler :: ServerT TestAPI App 54 | testSessionHandler = (newTenant :<|> getTenant) :<|> newSession :<|> productHandler 55 | 56 | productHandler :: ServerT (ProtectEndpoints ProductAPI) App 57 | productHandler = (\id -> either handleError (liftIO . print)) 58 | :<|> (either handleError $ const $ return [()]) 59 | where handleError NotPresent = throwError $ err403 { errBody = "Please log in" } 60 | handleError _ = throwError $ err403 { errBody = "Session invalid" } 61 | 62 | testServer :: Config -> Server TestAPI 63 | testServer config = enter (Nat $ flip runReaderT config) testSessionHandler 64 | 65 | -------------------------------------------------------------------------------- /ServantPersistent/src/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# LANGUAGE TypeOperators #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE DeriveAnyClass #-} 6 | {-# LANGUAGE DeriveFunctor #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | module Types 9 | where 10 | 11 | import Data.Aeson 12 | import Servant 13 | import Servant.Server.Experimental.Auth.Cookie 14 | import GHC.Generics 15 | import Control.Monad.Except 16 | import Control.Monad.Reader 17 | import Data.Serialize 18 | import Data.Text 19 | import Data.Time.Clock 20 | import Control.Lens hiding ((.=)) 21 | import Database.Persist.Sql 22 | import Database.Persist.TH 23 | 24 | data Environment = Test | Devel | Production deriving (Eq, Show) 25 | 26 | data CookieError = NotPresent | AuthError AuthCookieException deriving (Eq, Show) 27 | 28 | data Config = Config 29 | { authSettings :: AuthCookieSettings 30 | , randomSource :: RandomSource 31 | , serverKey :: ServerKey 32 | , environment :: Environment 33 | , dbPool :: ConnectionPool 34 | } 35 | 36 | type App = (ReaderT Config (ExceptT ServantErr IO)) 37 | 38 | data LoginForm = Login { loginUsername :: String 39 | , loginPassword :: String 40 | } deriving (Show, Generic, Serialize, FromJSON, ToJSON) 41 | 42 | data Session = Session { sessionUser :: String 43 | } deriving (Show, Generic, Serialize, FromJSON , ToJSON) 44 | 45 | 46 | data UserStatus = BlockedU | InactiveU | ActiveU 47 | deriving (Read, Show, Generic, Serialize, FromJSON , ToJSON) 48 | derivePersistField "UserStatus" 49 | 50 | data TenantStatus = NewT | InactiveT | ActiveT 51 | deriving (Eq, Read, Show, Generic, Serialize, FromJSON , ToJSON) 52 | derivePersistField "TenantStatus" 53 | 54 | class HasTimestamp s where 55 | createdAt :: Lens' s UTCTime 56 | updatedAt :: Lens' s UTCTime 57 | 58 | class HasName a where 59 | name :: Lens' a Text 60 | class HasBackofficeDomain a where 61 | backofficeDomain :: Lens' a Text 62 | 63 | class HasHumanName a where 64 | firstName :: Lens' a Text 65 | lastName :: Lens' a Text 66 | 67 | class HasContactDetails a where 68 | email :: Lens' a Text 69 | phone :: Lens' a Text 70 | 71 | class HasUsername a where 72 | username :: Lens' a Text 73 | 74 | class HasPassword a where 75 | password :: Lens' a Text 76 | 77 | -------------------------------------------------------------------------------- /ServantPersistent/src/Updater.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE TypeFamilies #-} 3 | {-# LANGUAGE ConstraintKinds #-} 4 | {-# LANGUAGE PolyKinds #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | {-# LANGUAGE TypeSynonymInstances #-} 7 | {-# LANGUAGE ImpredicativeTypes #-} 8 | {-# LANGUAGE FlexibleInstances #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE RankNTypes #-} 11 | {-# LANGUAGE DataKinds #-} 12 | module Updater 13 | where 14 | 15 | import Control.Lens 16 | import Data.Aeson 17 | import Data.Aeson.Types (Parser) 18 | import Data.Text (Text) 19 | import GHC.Types 20 | import Types 21 | 22 | 23 | type family AllC (cs :: [k -> Constraint]) (a :: k) :: Constraint where 24 | AllC '[] a = () 25 | AllC (c ': cs) a = (c a, AllC cs a) 26 | 27 | newtype Updater cs = U { runUpdate :: forall a. AllC cs a => a -> a } 28 | 29 | instance forall cs. Monoid (Updater cs) where 30 | mempty = U id 31 | (U a) `mappend` (U b) = U $ (a . b) 32 | 33 | parseUpdater :: forall cs a. FromJSON a => Object -> Text -> (a -> Updater cs) -> Parser (Updater cs) 34 | parseUpdater v t setter = maybe (mempty :: Updater cs) setter <$> v .:? t 35 | 36 | type TenantUpdater = Updater '[HasName, HasBackofficeDomain] 37 | 38 | tu :: (forall a. (HasName a, HasBackofficeDomain a) => a -> a) -> TenantUpdater 39 | tu = U 40 | 41 | instance FromJSON TenantUpdater where 42 | parseJSON (Object v) = 43 | mconcat <$> f 44 | where f = sequence 45 | [ parseUpdater v "name" (\x-> U $ set name x) 46 | , parseUpdater v "backoffice_domain" (\x-> U $ set backofficeDomain x) 47 | ] 48 | parseJSON _ = fail "Need an object" 49 | 50 | type UserUpdater = Updater '[HasHumanName, HasContactDetails] 51 | 52 | uu :: (forall a. (HasHumanName a, HasContactDetails a) => a -> a) -> UserUpdater 53 | uu = U 54 | 55 | instance FromJSON UserUpdater where 56 | parseJSON (Object v) = 57 | mconcat <$> f 58 | where f = sequence 59 | [ parseUpdater v "first_name" (\x -> U $ set firstName x) 60 | , parseUpdater v "last_name" (\x -> U $ set lastName x) 61 | , parseUpdater v "email" (\x -> U $ set email x) 62 | , parseUpdater v "phone" (\x -> U $ set phone x) 63 | ] 64 | parseJSON _ = fail "Need an object" 65 | -------------------------------------------------------------------------------- /ServantPersistent/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-7.3 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.2" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /ServantPersistent/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /SpockOpaleye/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /SpockOpaleye/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /SpockOpaleye/SpockOpaleye.cabal: -------------------------------------------------------------------------------- 1 | name: SpockOpaleye 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/githubuser/SpockOpaleye#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2016 Author name here 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Lib, 19 | TenantApi, 20 | UserApi, 21 | RoleApi, 22 | OpaleyeDef, 23 | CryptoDef, 24 | JsonInstances, 25 | Validations, 26 | DataTypes 27 | build-depends: base >= 4.7 && < 5 28 | ,product-profunctors 29 | ,bytestring 30 | ,opaleye 31 | ,postgresql-simple 32 | ,bcrypt 33 | ,text 34 | ,lens 35 | ,mtl 36 | ,Spock >=0.11 37 | ,aeson 38 | default-language: Haskell2010 39 | 40 | executable SpockOpaleye-exe 41 | hs-source-dirs: app 42 | main-is: Main.hs 43 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -fwarn-tabs -fwarn-unused-imports -fwarn-missing-signatures -fwarn-incomplete-patterns 44 | build-depends: base 45 | , postgresql-simple 46 | , SpockOpaleye 47 | , Spock >=0.11 48 | , mtl 49 | , lens 50 | , text 51 | , bcrypt 52 | , aeson 53 | default-language: Haskell2010 54 | 55 | test-suite SpockOpaleye-test 56 | type: exitcode-stdio-1.0 57 | hs-source-dirs: test 58 | main-is: Spec.hs 59 | build-depends: base 60 | , SpockOpaleye 61 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 62 | default-language: Haskell2010 63 | 64 | source-repository head 65 | type: git 66 | location: https://github.com/githubuser/SpockOpaleye 67 | -------------------------------------------------------------------------------- /SpockOpaleye/app/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Main where 4 | 5 | import Database.PostgreSQL.Simple 6 | import DataTypes 7 | import JsonInstances () 8 | import TenantApi 9 | import Validations 10 | 11 | import Web.Spock 12 | import Web.Spock.Config 13 | 14 | import qualified Data.Text as T 15 | 16 | data MySession = 17 | EmptySession 18 | 19 | data MyAppState = DummyAppState 20 | 21 | connectDb :: IO Connection 22 | connectDb = connect defaultConnectInfo { connectDatabase = "haskell-webapps" } 23 | 24 | main :: IO () 25 | main = do 26 | spockCfg <- 27 | defaultSpockCfg 28 | EmptySession 29 | (PCConn $ ConnBuilder connectDb close (PoolCfg 10 10 10)) 30 | DummyAppState 31 | runSpock 8080 (spock spockCfg app) 32 | 33 | app :: SpockM Connection MySession MyAppState () 34 | app = do 35 | post ("tenants/new") $ 36 | do maybe_tenant_incoming <- jsonBody 37 | maybe_newtenant <- 38 | case maybe_tenant_incoming of 39 | Just incoming_tenant -> do 40 | result <- 41 | runQuery (\conn -> validateIncomingTenant conn incoming_tenant) 42 | case result of 43 | Valid -> runQuery (\conn -> create_tenant conn incoming_tenant) 44 | _ -> return Nothing 45 | Nothing -> return Nothing 46 | case maybe_newtenant of 47 | Just tenant -> json tenant 48 | _ -> json $ T.pack "Tenant not created" 49 | -------------------------------------------------------------------------------- /SpockOpaleye/src/CryptoDef.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module CryptoDef 6 | ( BcryptPassword 7 | , bcryptPassword 8 | ) where 9 | 10 | import Crypto.BCrypt 11 | import Data.ByteString 12 | import qualified Data.Profunctor.Product.Default as D 13 | import Data.Text 14 | import Data.Text.Encoding 15 | import Database.PostgreSQL.Simple.FromField 16 | import Opaleye 17 | 18 | newtype BcryptPassword = 19 | BcryptPassword ByteString 20 | deriving (Show) 21 | 22 | bcryptPassword :: Text -> IO (Maybe BcryptPassword) 23 | bcryptPassword password = do 24 | hash <- 25 | hashPasswordUsingPolicy slowerBcryptHashingPolicy (encodeUtf8 password) 26 | return $ BcryptPassword <$> hash 27 | 28 | instance D.Default Constant (BcryptPassword) (Column PGBytea) where 29 | def = Constant def' 30 | where 31 | def' :: BcryptPassword -> (Column PGBytea) 32 | def' (BcryptPassword hash) = pgStrictByteString $ hash 33 | 34 | instance FromField BcryptPassword where 35 | fromField field mdata = do 36 | x <- fromField field mdata 37 | return $ BcryptPassword x 38 | 39 | instance QueryRunnerColumnDefault PGBytea BcryptPassword where 40 | queryRunnerColumnDefault = fieldQueryRunnerColumn 41 | -------------------------------------------------------------------------------- /SpockOpaleye/src/DataTypes.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | 3 | module DataTypes where 4 | 5 | import CryptoDef 6 | import Data.List.NonEmpty 7 | import Data.Text 8 | import GHC.Generics 9 | 10 | data ValidationResult = Valid | Invalid 11 | deriving (Eq, Show) 12 | 13 | newtype TenantId = TenantId Int 14 | deriving (Show, Generic) 15 | 16 | data TenantStatus = TenantStatusActive | TenantStatusInActive | TenantStatusNew 17 | deriving (Show, Generic) 18 | 19 | data TenantPoly key name fname lname email phone status owner_id b_domain = Tenant 20 | { tenant_id :: key 21 | , tenant_name :: name 22 | , tenant_firstname :: fname 23 | , tenant_lastname :: lname 24 | , tenant_email :: email 25 | , tenant_phone :: phone 26 | , tenant_status :: status 27 | , tenant_ownerid :: owner_id 28 | , tenant_backofficedomain :: b_domain 29 | } deriving (Show, Generic) 30 | 31 | type Tenant = TenantPoly TenantId Text Text Text Text Text TenantStatus (Maybe UserId) Text 32 | 33 | type TenantIncoming = TenantPoly () Text Text Text Text Text () (Maybe UserId) Text 34 | 35 | data UserStatus = UserStatusActive | UserStatusInActive | UserStatusBlocked 36 | deriving (Show) 37 | 38 | newtype UserId = UserId Int 39 | deriving (Show, Generic) 40 | 41 | data UserPoly key tenant_id username password firstname lastname status = User { 42 | user_id :: key, 43 | user_tenantid :: tenant_id, 44 | user_username :: username, 45 | user_password :: password, 46 | user_firstname :: firstname, 47 | user_lastname :: lastname, 48 | user_status :: status 49 | } 50 | 51 | type User = UserPoly UserId TenantId Text BcryptPassword (Maybe Text) (Maybe Text) UserStatus 52 | 53 | data Permission = Read | Create | Update | Delete 54 | deriving (Show) 55 | 56 | newtype RoleId = RoleId Int 57 | deriving (Show) 58 | 59 | data RolePoly key tenant_id name permission = Role 60 | { role_id :: key 61 | , role_tenantid :: tenant_id 62 | , role_name :: name 63 | , role_permission :: permission 64 | } deriving (Show) 65 | 66 | type Role = RolePoly RoleId TenantId Text (NonEmpty Permission) 67 | -------------------------------------------------------------------------------- /SpockOpaleye/src/JsonInstances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeSynonymInstances #-} 4 | 5 | module JsonInstances where 6 | 7 | import Control.Monad 8 | import Data.Aeson 9 | import Data.Aeson.Types 10 | import Data.Text 11 | import DataTypes 12 | 13 | instance FromJSON UserId where 14 | parseJSON j@(Number v) = UserId <$> (parseJSON j) 15 | parseJSON invalid = typeMismatch "UserId" invalid 16 | 17 | instance FromJSON TenantId where 18 | parseJSON j@(Number v) = TenantId <$> (parseJSON j) 19 | parseJSON invalid = typeMismatch "TenantId" invalid 20 | 21 | instance FromJSON TenantStatus where 22 | parseJSON j@(String v) = t_status <$> (parseJSON j) 23 | where 24 | t_status :: Text -> TenantStatus 25 | t_status "active" = TenantStatusActive 26 | t_status "inactive" = TenantStatusInActive 27 | t_status "new" = TenantStatusNew 28 | parseJSON invalid = typeMismatch "TenantStatus" invalid 29 | 30 | instance FromJSON TenantIncoming where 31 | parseJSON (Object v) = 32 | (Tenant ()) <$> v .: "name" <*> v .: "firstname" <*> v .: "lastname" <*> 33 | v .: "email" <*> 34 | v .: "phone" <*> 35 | (pure ()) <*> 36 | v .: "userId" <*> 37 | v .: "backofficeDomain" 38 | 39 | instance ToJSON TenantStatus where 40 | toJSON = genericToJSON defaultOptions 41 | toEncoding = 42 | genericToEncoding 43 | defaultOptions 44 | { constructorTagModifier = tg_modify 45 | } 46 | where 47 | tg_modify :: String -> String 48 | tg_modify "TenantStatusActive" = "active" 49 | tg_modify "TenantStatusInActive" = "inactive" 50 | tg_modify "TenantStatusNew" = "new" 51 | 52 | instance ToJSON Tenant where 53 | toJSON = genericToJSON defaultOptions 54 | toEncoding = 55 | genericToEncoding 56 | defaultOptions 57 | { fieldLabelModifier = remove_prefix 58 | } 59 | where 60 | remove_prefix = Prelude.drop 7 61 | 62 | instance ToJSON UserId where 63 | toJSON = genericToJSON defaultOptions 64 | toEncoding = genericToEncoding defaultOptions 65 | 66 | instance ToJSON TenantId where 67 | toJSON = genericToJSON defaultOptions 68 | toEncoding = genericToEncoding defaultOptions 69 | -------------------------------------------------------------------------------- /SpockOpaleye/src/Lib.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | 7 | module Lib 8 | ( 9 | ) where 10 | -------------------------------------------------------------------------------- /SpockOpaleye/src/RoleAPi.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | 7 | module RoleApi 8 | ( create_role 9 | , remove_role 10 | , read_roles_for_tenant 11 | ) where 12 | 13 | import Control.Arrow 14 | import Data.List.NonEmpty 15 | import Data.Text 16 | import Database.PostgreSQL.Simple (Connection) 17 | import DataTypes 18 | import GHC.Int 19 | import Opaleye 20 | import OpaleyeDef 21 | 22 | create_role :: Connection -> Role -> IO (Maybe Role) 23 | create_role conn role@Role { role_tenantid = tenant_id , role_name = name , role_permission = rp } = do 24 | ids <- 25 | runInsertManyReturning 26 | conn roleTable (return Role { 27 | role_id = Nothing, 28 | role_tenantid = constant tenant_id, 29 | role_name = pgStrictText name, 30 | role_permission = constant rp 31 | }) id 32 | return $ case ids of 33 | [] -> Nothing 34 | (x:xs) -> Just x 35 | 36 | remove_role :: Connection -> Role -> IO GHC.Int.Int64 37 | remove_role conn Role {role_id = t_id} = do 38 | runDelete conn userRolePivotTable (\(_, role_id) -> role_id .== constant t_id) 39 | runDelete conn roleTable match_func 40 | where 41 | match_func Role {role_id = id} = id .== constant t_id 42 | 43 | read_roles_for_tenant :: Connection -> TenantId -> IO [Role] 44 | read_roles_for_tenant conn t_id = do 45 | runQuery conn $ role_query_for_tenant t_id 46 | 47 | role_query :: Query RoleTableR 48 | role_query = queryTable roleTable 49 | 50 | role_query_for_tenant :: TenantId -> Query RoleTableR 51 | role_query_for_tenant t_tenantid = 52 | proc () -> 53 | do row@ Role {role_tenantid = tenant_id } <- role_query -< () 54 | restrict -< tenant_id .== (constant t_tenantid) 55 | returnA -< row 56 | -------------------------------------------------------------------------------- /SpockOpaleye/src/Validations.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Validations where 4 | 5 | import Data.Maybe 6 | import qualified Data.Text as T 7 | import Database.PostgreSQL.Simple 8 | import DataTypes 9 | import TenantApi 10 | 11 | validateIncomingTenant :: Connection -> TenantIncoming -> IO ValidationResult 12 | validateIncomingTenant conn tenant@Tenant {tenant_name = name 13 | ,tenant_firstname = fn 14 | ,tenant_lastname = ln 15 | ,tenant_email = em 16 | ,tenant_phone = phone 17 | ,tenant_backofficedomain = bo_domain} = do 18 | unique_bod <- check_for_unique_bo_domain 19 | return $ 20 | if and [unique_bod, validate_name, validate_contact] 21 | then Valid 22 | else Invalid 23 | where 24 | validate_contact = and $ (>= 0) . T.length <$> [fn, ln, em, phone] 25 | validate_name = (T.length name) >= 3 26 | check_for_unique_bo_domain = 27 | isNothing <$> read_tenant_by_backofficedomain conn bo_domain 28 | -------------------------------------------------------------------------------- /SpockOpaleye/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-7.5 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | - location: 41 | git: https://github.com/agrafix/Spock.git 42 | commit: 77333a2de5dea0dc8eba9432ab16864e93e5d70e 43 | subdirs: 44 | - Spock 45 | - Spock-core 46 | - reroute 47 | # Dependency packages to be pulled from upstream that are not in the resolver 48 | # (e.g., acme-missiles-0.3) 49 | extra-deps: [] 50 | 51 | # Override default flag values for local packages and extra-deps 52 | flags: {} 53 | 54 | # Extra package databases containing global packages 55 | extra-package-dbs: [] 56 | 57 | # Control whether we use the GHC we find on the path 58 | # system-ghc: true 59 | # 60 | # Require a specific version of stack, using version ranges 61 | # require-stack-version: -any # Default 62 | # require-stack-version: ">=1.2" 63 | # 64 | # Override the architecture used by stack, especially useful on Windows 65 | # arch: i386 66 | # arch: x86_64 67 | # 68 | # Extra directories used by stack for building 69 | # extra-include-dirs: [/path/to/dir] 70 | # extra-lib-dirs: [/path/to/dir] 71 | # 72 | # Allow a newer minor version of GHC than the snapshot specifies 73 | # compiler-check: newer-minor 74 | -------------------------------------------------------------------------------- /SpockOpaleye/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/README.org: -------------------------------------------------------------------------------- 1 | * Login with server side validation 2 | 3 | This repo implements a ui form for server side user validation. 4 | 5 | From a technical stanpoint, the aim of this project is to see how various 6 | libraries fit together: =reflex= and =reflex-dom= for the frontend, a simple 7 | =servant= server on the backend, the bridge among the two worlds being made with 8 | =servant-reflex=. 9 | 10 | Note the structure of the project: three separate cabal projects are created, 11 | one for the frontend, one for the backend, and one for the API and the shared 12 | datatypes, which is included in the other two. 13 | 14 | Also, in the frontend I provided two stack.yaml files. The main one is intended 15 | to be used with =ghc=, it generates the haddocks, behaves well with the tooling 16 | (intero), and builds a standalone desktop app. 17 | 18 | The second one, =stack-ghcjs.yaml= compiles the project with =ghcjs=. To call 19 | the stack commands for ghcjs just add the option =--stack-yaml=stack-ghcjs.yaml=. 20 | 21 | The build of the server should be just a =stack build=. To build the client: 22 | - =stack build gtk2hs-buildtools alex happy= 23 | - be sure to have the required system libraries (like webkitgtk) 24 | - =stack build= or =stack build --stack-yaml=stack-ghcjs.yaml= 25 | 26 | You can also use the =deploy.hs= in the client folder, which compiles the 27 | client, minimizes the generated js, and copies it in the location expected by 28 | the server. 29 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockAPI/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockAPI/mockAPI.cabal: -------------------------------------------------------------------------------- 1 | name: mockAPI 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | library 7 | hs-source-dirs: src 8 | exposed-modules: MockAPI 9 | build-depends: base >= 4.7 && < 5 10 | , servant 11 | , text 12 | , aeson 13 | default-language: Haskell2010 -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockAPI/src/MockAPI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds, DeriveGeneric, TypeOperators #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | module MockAPI where 5 | 6 | import Data.Aeson 7 | import Data.Text 8 | import GHC.Generics 9 | import Servant.API 10 | 11 | data User = User 12 | { userMail :: Text 13 | , userPassword :: Text 14 | } deriving (Show, Generic) 15 | 16 | instance ToJSON User 17 | instance FromJSON User 18 | 19 | type MockApi = "auth" :> ReqBody '[JSON] User :> Post '[JSON] Text 20 | :<|> "assets" :> Raw 21 | :<|> Raw 22 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockAPI/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.5 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | 8 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitForAll, NoImplicitPrelude, NoMonomorphismRestriction #-} 2 | {-# LANGUAGE OverloadedStrings, RecursiveDo, ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | {-# OPTIONS_GHC -fdefer-typed-holes #-} 6 | 7 | module Main where 8 | 9 | import ClassyPrelude 10 | import Data.Proxy 11 | import Reflex 12 | import Reflex.Dom 13 | import Servant.API 14 | import Servant.Reflex 15 | import qualified Language.Javascript.JSaddle.Warp as JSWarp (run) 16 | 17 | import MockAPI 18 | 19 | main :: IO () 20 | main = JSWarp.run 8081 $ mainWidget body 21 | 22 | body :: forall t m. MonadWidget t m => m () 23 | body = do 24 | -- Instructions to use the server at localhost and to invoke the api 25 | let url = BaseFullUrl Http "localhost" 8081 "" 26 | (invokeAPI :<|> _ :<|> _) = client (Proxy @MockApi) (Proxy @m) (constDyn url) 27 | 28 | -- A description of the visual elements 29 | divClass "login-clean" $ do 30 | el "form" $ do 31 | rec hiddenTitle 32 | icon 33 | mail <- _textInput_value <$> mailInputElement 34 | pass <- _textInput_value <$> passInputElement 35 | let userResult = liftA2 (User) mail pass 36 | send <- buttonElement send responseEvent 37 | forgot 38 | -- The actual API call 39 | apiResponse <- invokeAPI (Right <$> userResult) send 40 | let responseEvent = const () <$> apiResponse 41 | -- A visual feedback on authentication 42 | r <- holdDyn "" $ fmap parseR apiResponse 43 | el "h2" (dynText r) 44 | 45 | -------------------------------------------------------------------------------- 46 | -- Implementation of the visual elements: 47 | 48 | hiddenTitle, icon :: DomBuilder t m => m () 49 | hiddenTitle = elClass "h2" "sr-only" (text "Login Form") 50 | icon = divClass "illustration" (elClass "i" "icon ion-ios-navigate" $ pure ()) 51 | 52 | mailInputElement :: MonadWidget t m => m (TextInput t) 53 | mailInputElement = textInput $ 54 | def & textInputConfig_attributes .~ constDyn 55 | ("class" =: "form-control" <> "name" =: "email" <> "placeholder" =: "Email") 56 | & textInputConfig_inputType .~ "email" 57 | 58 | passInputElement :: MonadWidget t m => m (TextInput t) 59 | passInputElement = textInput $ 60 | def & textInputConfig_attributes .~ constDyn 61 | ("class" =: "form-control" <> "name" =: "password" <> "placeholder" =: "Password") 62 | & textInputConfig_inputType .~ "password" 63 | 64 | buttonElement :: DomBuilder t m => Event t () -> Event t () -> m (Event t ()) 65 | buttonElement disable enable = divClass "form-group" (styledButton conf "Log in") 66 | where 67 | conf = def & elementConfig_initialAttributes .~ initialAttr 68 | & elementConfig_modifyAttributes .~ mergeWith (\_ b -> b) 69 | [ const disableAttr <$> disable 70 | , const enableAttr <$> enable ] 71 | initialAttr = "class" =: "btn btn-primary btn-block" <> "type" =: "button" 72 | disableAttr = fmap Just initialAttr <> "disabled" =: Just "true" 73 | enableAttr = fmap Just initialAttr <> "disabled" =: Nothing 74 | 75 | forgot :: DomBuilder t m => m () 76 | forgot = elAttr "a" 77 | ("href" =: "#" <> "class" =: "forgot") 78 | (text "Forgot your email or password?") 79 | 80 | ----- This function should be contributed back to reflex-frp 81 | styledButton :: DomBuilder t m => ElementConfig EventResult t m -> Text -> m (Event t ()) 82 | styledButton conf t = do 83 | (e, _) <- element "button" conf (text t) 84 | return (domEvent Click e) 85 | 86 | 87 | -------------------------------------------------------------------------------- 88 | -- Parse the response from the API 89 | parseR :: ReqResult Text -> Text 90 | parseR (ResponseSuccess a _) = a 91 | parseR (ResponseFailure a _) = "ResponseFailure: " <> a 92 | parseR (RequestFailure s) = "RequestFailure: " <> s 93 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/assets/css/Login-Form-Clean.css: -------------------------------------------------------------------------------- 1 | .login-clean { 2 | background:#f1f7fc; 3 | padding:80px 0; 4 | } 5 | 6 | .login-clean form { 7 | max-width:320px; 8 | width:90%; 9 | margin:0 auto; 10 | background-color:#ffffff; 11 | padding:40px; 12 | border-radius:4px; 13 | color:#505e6c; 14 | box-shadow:1px 1px 5px rgba(0,0,0,0.1); 15 | } 16 | 17 | .login-clean .illustration { 18 | text-align:center; 19 | padding:0 0 20px; 20 | font-size:100px; 21 | color:rgb(244,71,107); 22 | } 23 | 24 | .login-clean form .form-control { 25 | background:#f7f9fc; 26 | border:none; 27 | border-bottom:1px solid #dfe7f1; 28 | border-radius:0; 29 | box-shadow:none; 30 | outline:none; 31 | color:inherit; 32 | text-indent:8px; 33 | height:42px; 34 | } 35 | 36 | .login-clean form .btn-primary { 37 | background:#f4476b; 38 | border:none; 39 | border-radius:4px; 40 | padding:11px; 41 | box-shadow:none; 42 | margin-top:26px; 43 | text-shadow:none; 44 | outline:none !important; 45 | } 46 | 47 | .login-clean form .btn-primary:hover, .login-clean form .btn-primary:active { 48 | background:#eb3b60; 49 | } 50 | 51 | .login-clean form .btn-primary:active { 52 | transform:translateY(1px); 53 | } 54 | 55 | .login-clean form .forgot { 56 | display:block; 57 | text-align:center; 58 | font-size:12px; 59 | color:#6f7a85; 60 | opacity:0.9; 61 | text-decoration:none; 62 | } 63 | 64 | .login-clean form .forgot:hover, .login-clean form .forgot:active { 65 | opacity:1; 66 | text-decoration:none; 67 | } 68 | 69 | .login-clean form h2 { 70 | opacity:1; 71 | text-align:center; 72 | } 73 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/assets/css/styles.css: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/UI/ReflexFRP/mockLoginPage/mockClient/assets/css/styles.css -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/assets/fonts/ionicons.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/UI/ReflexFRP/mockLoginPage/mockClient/assets/fonts/ionicons.eot -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/assets/fonts/ionicons.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/UI/ReflexFRP/mockLoginPage/mockClient/assets/fonts/ionicons.ttf -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/assets/fonts/ionicons.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/UI/ReflexFRP/mockLoginPage/mockClient/assets/fonts/ionicons.woff -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/assets/html/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | ui-mockups 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/deploy.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # Compiling with ghcjs 4 | stack build --stack-yaml=stack-ghcjs.yaml 5 | 6 | # Moving the generated files to the js folder 7 | rm -r js 8 | cp -r .stack-work/dist/x86_64-linux/Cabal-1.24.0.0_ghcjs/build/mockClient/mockClient.jsexe/ js 9 | 10 | # Swapping the default html with the one serving a minified version 11 | cp assets/html/index.html js/index.html 12 | 13 | # Minifying all.js file using the closure compiler, and removing unnecessary files 14 | cd js 15 | # ccjs all.js --debug --compilation_level=ADVANCED_OPTIMIZATIONS > all.min.js 16 | ccjs all.js > all.min.js 17 | rm all.js out.stats runmain.js lib.js out.js rts.js 18 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/js/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | ui-mockups 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/js/manifest.webapp: -------------------------------------------------------------------------------- 1 | { 2 | "name": "GHCJS Web Application", 3 | "description": "GHCJS Web Application", 4 | "launch_path": "/index.html", 5 | "icons": { 6 | "16": "/icons/icon16x16.png", 7 | "48": "/icons/icon48x48.png", 8 | "60": "/icons/icon60x60.png", 9 | "128": "/icons/icon128x128.png" 10 | }, 11 | "type": "privileged", 12 | "permissions": {} 13 | } -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/mockLoginPage.cabal: -------------------------------------------------------------------------------- 1 | name: mockLoginPage 2 | version: 0.1.0.0 3 | license: BSD3 4 | maintainer: meditans@gmail.com 5 | build-type: Simple 6 | cabal-version: >=1.10 7 | 8 | executable mockClient 9 | main-is: Main.hs 10 | build-depends: base >=4.9 && <4.10 11 | , reflex >= 0.5 && < 0.6 12 | , reflex-dom >= 0.4 && < 0.5 13 | , servant-reflex 14 | , containers 15 | , text 16 | , safe 17 | , string-conv 18 | , classy-prelude 19 | , email-validate 20 | , mockAPI 21 | , servant 22 | , jsaddle-warp 23 | default-language: Haskell2010 24 | if impl(ghcjs) 25 | ghc-options: -dedupe 26 | cpp-options: -DGHCJS_BROWSER 27 | else 28 | ghc-options: -Wall -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/stack-ghcjs.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.13 2 | compiler: ghcjs-0.2.1.9007013_ghc-8.0.1 3 | compiler-check: match-exact 4 | 5 | setup-info: 6 | ghcjs: 7 | source: 8 | ghcjs-0.2.1.9007013_ghc-8.0.1: 9 | url: http://ghcjs.tolysz.org/ghc-8.0-2016-12-18-lts-7.13-9007013.tar.gz 10 | sha1: 530c4ee5e19e2874e128431c7ad421e336df0303 11 | 12 | packages: 13 | - location: '.' 14 | - location: ../mockAPI 15 | extra-dep: true 16 | - location: 17 | git: https://github.com/reflex-frp/reflex 18 | commit: 91299fce0bb2caddfba35af6608df57dd31e3690 19 | extra-dep: true 20 | - location: 21 | git: https://github.com/hamishmack/reflex-dom 22 | commit: 00c773be07693f38d981d6b99fac4a0571d45bd0 23 | extra-dep: true 24 | - location: 25 | git: https://github.com/meditans/servant-reflex 26 | commit: 6953de90edc444f8f556b02639a2c64be6d1f6a9 27 | extra-dep: true 28 | - location: 29 | git: https://github.com/ghcjs/jsaddle 30 | commit: 02f215aec0622300fd68f0200c813356ed7cd738 31 | subdirs: 32 | - jsaddle 33 | - jsaddle-warp 34 | extra-dep: true 35 | - location: 36 | git: https://github.com/ghcjs/jsaddle-dom 37 | commit: 06351fe3562a2e6d096f6c862a9f5694ffd800d8 38 | extra-dep: true 39 | - location: 40 | git: https://github.com/ghcjs/ghcjs-dom 41 | commit: 93165cae1c02e0d3859b4cd515e6bf0f1581e79b 42 | extra-dep: true 43 | subdirs: 44 | - ghcjs-dom-jsffi 45 | 46 | extra-deps: 47 | - ghcjs-dom-0.7.0.3 48 | - ghcjs-dom-jsaddle-0.7.0.3 49 | - jsaddle-0.7.0.0 50 | - jsaddle-dom-0.7.0.3 51 | - jsaddle-warp-0.7.0.0 52 | - prim-uniq-0.1.0.1 53 | - ref-tf-0.4.0.1 54 | - zenc-0.1.1 55 | 56 | flags: {} 57 | 58 | extra-package-dbs: [] 59 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockClient/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.13 2 | 3 | packages: 4 | - location: '.' 5 | - location: ../mockAPI 6 | extra-dep: true 7 | - location: 8 | git: https://github.com/reflex-frp/reflex 9 | commit: 91299fce0bb2caddfba35af6608df57dd31e3690 10 | extra-dep: true 11 | - location: 12 | git: https://github.com/hamishmack/reflex-dom 13 | commit: 00c773be07693f38d981d6b99fac4a0571d45bd0 14 | extra-dep: true 15 | - location: 16 | git: https://github.com/meditans/servant-reflex 17 | commit: 6953de90edc444f8f556b02639a2c64be6d1f6a9 18 | extra-dep: true 19 | - location: 20 | git: https://github.com/ghcjs/jsaddle 21 | commit: 02f215aec0622300fd68f0200c813356ed7cd738 22 | subdirs: 23 | - jsaddle 24 | - jsaddle-warp 25 | extra-dep: true 26 | - location: 27 | git: https://github.com/ghcjs/jsaddle-dom 28 | commit: 06351fe3562a2e6d096f6c862a9f5694ffd800d8 29 | extra-dep: true 30 | - location: 31 | git: https://github.com/ghcjs/ghcjs-dom 32 | commit: 93165cae1c02e0d3859b4cd515e6bf0f1581e79b 33 | extra-dep: true 34 | subdirs: 35 | - ghcjs-dom-jsffi 36 | 37 | extra-deps: 38 | - ghcjs-dom-0.7.0.3 39 | - ghcjs-dom-jsaddle-0.7.0.3 40 | - jsaddle-0.7.0.0 41 | - jsaddle-dom-0.7.0.3 42 | - jsaddle-warp-0.7.0.0 43 | - prim-uniq-0.1.0.1 44 | - ref-tf-0.4.0.1 45 | - zenc-0.1.1 46 | 47 | flags: {} 48 | 49 | extra-package-dbs: [] 50 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockServer/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, TypeApplications #-} 2 | 3 | module Main where 4 | 5 | import MockAPI 6 | import Servant 7 | import Network.Wai.Handler.Warp 8 | import Data.Text (Text) 9 | import Control.Concurrent (threadDelay) 10 | import Control.Monad.IO.Class 11 | import qualified Data.Map as M 12 | import Network.Wai.Middleware.Gzip 13 | 14 | server :: Server MockApi 15 | server = authenticate :<|> serveAssets :<|> serveJS 16 | where 17 | serveAssets = serveDirectory "../mockClient/assets" 18 | serveJS = serveDirectory "../mockClient/js/" 19 | 20 | authenticate :: (Monad m, MonadIO m) => User -> m Text 21 | authenticate u 22 | | correctInfo = liftIO (threadDelay 1000000) >> return "Authenticated" 23 | | userPresent = liftIO (threadDelay 1000000) >> return "Wrong password" 24 | | otherwise = liftIO (threadDelay 1000000) >> return "Not Authenticated" 25 | where 26 | users = M.fromList [ ("user1@gmail.com", "pass1") 27 | , ("user2@gmail.com", "pass2") 28 | , ("user3@gmail.com", "pass3") 29 | ] 30 | correctInfo = M.lookup (userMail u) users == Just (userPassword u) 31 | userPresent = userMail u `elem` M.keys users 32 | 33 | main :: IO () 34 | main = run 8081 (gzip gzipSettings $ serve (Proxy @MockApi) server) 35 | -- main = run 8081 (serve (Proxy @MockApi) server) 36 | where 37 | gzipSettings = def { gzipFiles = GzipCompress } 38 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockServer/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockServer/mockServer.cabal: -------------------------------------------------------------------------------- 1 | name: mockServer 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >=1.10 5 | 6 | executable mockServer 7 | hs-source-dirs: . 8 | main-is: Main.hs 9 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 10 | build-depends: base 11 | , containers 12 | , mockAPI 13 | , servant-server 14 | , text 15 | , warp 16 | , wai-extra 17 | default-language: Haskell2010 -------------------------------------------------------------------------------- /UI/ReflexFRP/mockLoginPage/mockServer/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.5 2 | 3 | packages: 4 | - '.' 5 | - location: ../mockAPI 6 | extra-dep: false 7 | 8 | extra-deps: [] 9 | 10 | flags: {} 11 | 12 | extra-package-dbs: [] 13 | -------------------------------------------------------------------------------- /UI/ReflexFRP/starterApp/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Carlo Nucera (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Carlo Nucera nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /UI/ReflexFRP/starterApp/README.org: -------------------------------------------------------------------------------- 1 | * A simple example of client side validation with reflex 2 | To build the demo: 3 | - Clone this repo 4 | - =stack build gtk2hs-buildtools= 5 | - Iy the meantime, be sure to have the required system libraries (like webkitgtk). If you miss some of the libraries, they will pop up as error in the next step. 6 | - =stack build= 7 | - =stack exec userValidation= 8 | -------------------------------------------------------------------------------- /UI/ReflexFRP/starterApp/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /UI/ReflexFRP/starterApp/deploy.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | 3 | # Compiling with ghcjs: 4 | stack build --stack-yaml=stack-ghcjs.yaml 5 | 6 | # Moving the generated files to the js folder: 7 | mkdir -p js 8 | cp -r $(stack path --local-install-root --stack-yaml=stack-ghcjs.yaml)/bin/starterApp.jsexe/all.js js/ 9 | 10 | # Minifying all.js file using the closure compiler: 11 | cd js 12 | ccjs all.js --compilation_level=ADVANCED_OPTIMIZATIONS > all.min.js 13 | 14 | # OPTIONAL: zipping, to see the actual transferred size of the app: 15 | zopfli all.min.js 16 | -------------------------------------------------------------------------------- /UI/ReflexFRP/starterApp/stack-ghcjs.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.8 2 | compiler: ghcjs-0.2.1.9007008_ghc-8.0.1 3 | compiler-check: match-exact 4 | 5 | setup-info: 6 | ghcjs: 7 | source: 8 | ghcjs-0.2.1.9007008_ghc-8.0.1: 9 | url: http://ghcjs.tolysz.org/ghc-8.0-2016-11-07-lts-7.8-9007008.tar.gz 10 | sha1: 190300a3725cde44b2a08be9ef829f2077bf8825 11 | 12 | packages: 13 | - location: '.' 14 | - location: 15 | git: https://github.com/reflex-frp/reflex 16 | commit: 91299fce0bb2caddfba35af6608df57dd31e3690 17 | # Latest develop comment at the time of writing 18 | extra-dep: true 19 | - location: 20 | git: https://github.com/hamishmack/reflex-dom 21 | commit: d9842742183a800cf1f98f89d42d849d52dd2d67 22 | # Latest develop comment at the time of writing 23 | extra-dep: true 24 | 25 | extra-deps: 26 | - ghcjs-dom-0.7.0.3 27 | - ghcjs-dom-jsaddle-0.7.0.3 28 | - ghcjs-dom-jsffi-0.7.0.3 29 | - jsaddle-0.7.0.0 30 | - jsaddle-dom-0.7.0.3 31 | - jsaddle-warp-0.7.0.0 32 | - prim-uniq-0.1.0.1 33 | - ref-tf-0.4.0.1 34 | - zenc-0.1.1 35 | -------------------------------------------------------------------------------- /UI/ReflexFRP/starterApp/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.8 2 | 3 | packages: 4 | - location: '.' 5 | - location: 6 | git: https://github.com/reflex-frp/reflex 7 | commit: 91299fce0bb2caddfba35af6608df57dd31e3690 8 | # Latest develop comment at the time of writing 9 | extra-dep: true 10 | - location: 11 | git: https://github.com/hamishmack/reflex-dom 12 | commit: d9842742183a800cf1f98f89d42d849d52dd2d67 13 | # Latest develop comment at the time of writing 14 | extra-dep: true 15 | 16 | extra-deps: 17 | - ghcjs-dom-0.7.0.3 18 | - ghcjs-dom-jsaddle-0.7.0.3 19 | - jsaddle-0.7.0.0 20 | - jsaddle-dom-0.7.0.3 21 | - jsaddle-warp-0.7.0.0 22 | - prim-uniq-0.1.0.1 23 | - ref-tf-0.4.0.1 24 | - zenc-0.1.1 25 | 26 | flags: {} 27 | 28 | extra-package-dbs: [] 29 | -------------------------------------------------------------------------------- /UI/ReflexFRP/starterApp/starterApp.cabal: -------------------------------------------------------------------------------- 1 | name: starterApp 2 | version: 0.1.0.0 3 | license: BSD3 4 | license-file: LICENSE 5 | maintainer: meditans@gmail.com 6 | build-type: Simple 7 | cabal-version: >=1.10 8 | 9 | executable starterApp 10 | main-is: Main.hs 11 | build-depends: base >=4.9 && <4.10 12 | , reflex >= 0.5 && < 0.6 13 | , reflex-dom >= 0.4 && < 0.5 14 | , classy-prelude 15 | , email-validate 16 | , string-conv 17 | , jsaddle-warp 18 | default-language: Haskell2010 19 | 20 | if impl(ghcjs) 21 | ghc-options: -dedupe 22 | cpp-options: -DGHCJS_BROWSER 23 | else 24 | ghc-options: -Wall 25 | -------------------------------------------------------------------------------- /doc/.gitignore: -------------------------------------------------------------------------------- 1 | _cache/ 2 | 3 | -------------------------------------------------------------------------------- /doc/_templates/footer.html: -------------------------------------------------------------------------------- 1 |
2 | 10 | 11 |
12 | 13 |
14 | Interested in using Haskell to build a rock-solid web platform? We are (remote) hiring Haskellers at Vacation Labs! 15 |
16 | 17 |
18 | 19 |
20 |

21 | {%- if show_copyright %} 22 | {%- if hasdoc('copyright') %} 23 | {% trans path=pathto('copyright'), copyright=copyright|e %}© Copyright {{ copyright }}.{% endtrans %} 24 | {%- else %} 25 | {% trans copyright=copyright|e %}© Copyright {{ copyright }}.{% endtrans %} 26 | {%- endif %} 27 | {%- endif %} 28 | 29 | {%- if build_id and build_url %} 30 | {% trans build_url=build_url, build_id=build_id %} 31 | 32 | Build 33 | {{ build_id }}. 34 | 35 | {% endtrans %} 36 | {%- elif commit %} 37 | {% trans commit=commit %} 38 | 39 | Revision {{ commit }}. 40 | 41 | {% endtrans %} 42 | {%- elif last_updated %} 43 | {% trans last_updated=last_updated|e %}Last updated on {{ last_updated }}.{% endtrans %} 44 | {%- endif %} 45 | 46 |

47 |
48 | 49 | {%- if show_sphinx %} 50 | {% trans %}Built with Sphinx using a theme provided by Read the Docs{% endtrans %}. 51 | {%- endif %} 52 | 53 | {%- block extrafooter %} {% endblock %} 54 | 55 |
56 | -------------------------------------------------------------------------------- /doc/docs/framework/deploying.rst: -------------------------------------------------------------------------------- 1 | Deploying 2 | ================================= 3 | 4 | Using stack with Docker 5 | ----------------------- 6 | 7 | NOTE: If you are using Windows operating system, this is not yet working for Windows. Watch this 8 | issue https://github.com/commercialhaskell/stack/issues/2421 9 | 10 | The Stack tool has built in support for executing builds inside a docker container. But first 11 | you have to set up some stuff on your machine. First of which is installing docker on your system. 12 | 13 | https://docs.docker.com/engine/installation/ 14 | 15 | Download and install the CE (Community Edition) version. After the installation 16 | you should have a ``docker`` command available in your terminal. 17 | 18 | Try the docker command ``docker images`` and see if works without errors. If 19 | you are getting a permission denied error, try running the following command, 20 | 21 | sudo usermod -a -G docker $USER 22 | 23 | NOTE: After the above command, you should completly log out and log in to see the affect. 24 | Or if you cannot do that, just relogin as the same user, for ex, if you are loggied in as user ``vl`` 25 | just do a ``su vl`` and that should be enough. 26 | 27 | Next you have to build the docker image that we will use for our builds. You have two options here. 28 | 29 | 1. You can either build one from using the docker file 30 | 2. You can pull a prebuilt image from the docker hub. 31 | 32 | Building from docker file 33 | ------------------------- 34 | 35 | Open up a terminal and go to the root of the app. There should be a ``docker`` folder there. Go to that folder, 36 | and do ``docker build .`` there. 37 | 38 | .. code:: bash 39 | 40 | cd docker 41 | docker build -t vacationlabs-ubuntu . 42 | 43 | When this is done, you will have a new docker image with name "vl-ubuntu-image". 44 | 45 | Configuring Stack 46 | ----------------- 47 | 48 | Your stack.yaml will contain the following lines. 49 | 50 | .. code:: yaml 51 | 52 | docker: 53 | env: 54 | - "APP_ENV=development" 55 | enabled: false 56 | image: vacationlabs-ubuntu 57 | run-args: ["--ulimit=nofile=60000", "--memory=4g"] 58 | 59 | 1. The ``env`` key contains a list and is used to set environment variables inside the container 60 | before the build.yaml 61 | 62 | 2. The ``enabled`` flag set to false to NOT use docker by default. Docker will be involved only 63 | upon specifing the command line flag ``--docker``. 64 | 65 | 2. The ``image`` key is used to specify the docker image from which the container for the build will be made. 66 | This should already exist. 67 | 68 | 3. The ``run-args`` key us used to pass arguments to the docker command that created the container. Here we 69 | have used it to increase the maximum number of open files that will be allowed inside the container and 70 | the maximum amount of host memory the container is allowed to use. 71 | 72 | Now you can build the app using the ``stack build --docker`` 73 | 74 | When you do this for the first time, stack will complain there is no compiler installed in 75 | the container. Just use ``--install-ghc`` flag like ``stack build --docker --install-ghc``. And it will 76 | install the compiler inside the container. 77 | 78 | Stack will mount the ~/.stack folder inside the container, so installing compiler and dependencies 79 | only need to be done once. That is unless you change the image for the container. 80 | 81 | If you find that stack gets stalled after downloading the compiler at around 90mb, you can just download 82 | the required tar archive from https://github.com/commercialhaskell/ghc/releases to the ``~/.stack/programs/x86_64-linux-*`` folder and name it using format ``ghc-8.0.2.tar.xz`` and run the build command again. That stack will use 83 | downloaded archive instead of downloading it again. 84 | 85 | After the build, the binary file will be in the usual location. 86 | 87 | 88 | Further reference : https://docs.haskellstack.org/en/stable/docker_integration/ 89 | -------------------------------------------------------------------------------- /doc/docs/framework/index.rst: -------------------------------------------------------------------------------- 1 | Webapp Framework 2 | ================ 3 | 4 | Contents: 5 | 6 | .. toctree:: 7 | :maxdepth: 2 8 | 9 | migrations 10 | basic-crud 11 | strict-validations 12 | deploying 13 | 14 | 15 | Outline 16 | ------- 17 | 18 | 19 | #. Overall project layout - partial design:: 20 | 21 | projectRoot 22 | | 23 | |-- src 24 | | | 25 | | |-- Models 26 | | | | 27 | | | |-- User 28 | | | | \-- Types 29 | | | | 30 | | | |-- Customer 31 | | | | \-- Types 32 | | | | 33 | | | |-- Order 34 | | | | \-- Types 35 | | | | 36 | | | \-- (and so on) 37 | | | 38 | | |-- Endpoints 39 | | | | 40 | | | |-- User 41 | | | | \-- Types 42 | | | | 43 | | | |-- Customer 44 | | | | \-- Types 45 | | | | 46 | | | |-- Order 47 | | | | \-- Types 48 | | | | 49 | | | \-- (and so on) 50 | | | 51 | | \-- Foundation 52 | | | Import 53 | | | DBImport 54 | | \-- Types 55 | | |-- Currency 56 | | |-- PrimaryKey 57 | | |-- Config 58 | | \-- (and so on) 59 | | 60 | |-- app 61 | | \-- Main 62 | | 63 | | 64 | |-- autogen 65 | | \-- AutoGenarated 66 | | | 67 | | |-- Models 68 | | | |-- User 69 | | | |-- Customer 70 | | | |-- Order 71 | | | \-- (and so on) 72 | | | 73 | | |-- PrimaryKeys 74 | | | |-- UserId 75 | | | |-- CustomerId 76 | | | |-- OrderId 77 | | | \-- (and so on) 78 | | | 79 | | \-- Classes (used for lenses) 80 | | |-- Id 81 | | |-- Name 82 | | |-- Phone 83 | | \-- (and so on) 84 | | 85 | |-- autogen-config.yml 86 | | 87 | \-- scripts 88 | 89 | #. Models / Database 90 | 91 | #. Naming conventions - almost final design 92 | #. Migrations: Creating and editing models - almost final 93 | #. Strict validations - WIP 94 | #. Query helpers - partial design 95 | #. DB transactions & savepoints - partial design 96 | 97 | #. Creating JSON APIs - WIP 98 | 99 | #. Basic JSON API - almost final 100 | #. API-specific validations - WIP 101 | #. File-uploads - WIP 102 | 103 | #. Frontend/UI code 104 | 105 | #. Communicating with JSON APIs - WIP 106 | #. Validations - WIP 107 | #. Static assets - WIP 108 | 109 | #. Logging 110 | 111 | #. File based logging - almost final 112 | #. Exception/error notifications - WIP 113 | #. Performance metrics in production - WIP 114 | 115 | #. Sending emails - almost final 116 | #. Job queues - partial design 117 | #. Testing - WIP 118 | #. Deployment - WIP 119 | #. Authentication & authorization - WIP 120 | #. Audit logs - partial design 121 | -------------------------------------------------------------------------------- /doc/docs/framework/strict-validations.rst: -------------------------------------------------------------------------------- 1 | General validation helpers 2 | ========================== 3 | 4 | .. code:: haskell 5 | 6 | -- 7 | validateLength :: (Foldable t, Monoid e, MonadIO m) => Text -> (Int, Int) -> Getting (t a) s (t a) -> s -> m e 8 | 9 | -- NOTE: The type signature is probably incomplete. Please refer to the usage 10 | -- sample to figure out what the actual type signature needs to be. 11 | validateFormat :: (MonadIO m, Monoid e) => m RE -> Lens' s a -> s -> m e 12 | 13 | -- Strips the field of all leading and trailing whitespace and then ensures 14 | -- that is not a blank string. TODO: Should the whitespace-stripped string be 15 | -- stored in the DB? How do we ensure that? 16 | validatePresence :: (Monoid e, MonadIO m) => Text -> Getting Text s Text -> s -> m e 17 | 18 | -- Ensures that a field is either Nothing OR a blank string (ignoring all 19 | -- leading and trailing whitespace). TODO: How do we ensure that a blank-string 20 | -- is actually treated as a Nothing when storing into the DB? Also, is there a 21 | -- use-case for having a non-Maybe (i.e. NOT NULL) field, which is validated to 22 | -- be a blank string? 23 | validateAbsence :: (Monoid e, MonadIO m) => Text -> Getting (Maybe Text) s (Maybe Text) -> s -> m e 24 | 25 | -- This will end up making a DB call, because of which, more class - 26 | -- constraints will get added. Like `Default Constant a1 (Column a1)`. Also, 27 | -- please NOTE - you have to be careful while querying the DB for rows with the 28 | -- same fields to NOT match the record which is being validated. This can be 29 | -- ensured by passing another condition to `filterN` - 30 | -- (id, pgNotEq, record ^.id) 31 | validateUnique1 :: (Monoid e, HasDatabase m) => Text -> (Getting a1 s a1) -> s -> m e 32 | validateUnique2 :: (Monoid e, HasDatabase m) => Text -> (Getting a1 s a1, Getting a2 s a2) -> s -> m e 33 | validateUnique3 :: (Monoid e, HasDatabase m) => Text -> (Getting a1 s a1, Getting a2 s a2, Getting a3 s a3) -> s -> m e 34 | -- and so on... til validateUnique5 35 | 36 | -- 37 | validateIn :: (Monoid e, MonadIO m) => Text -> [a] -> Getting [a] s [a] -> s -> m e 38 | 39 | Strict model validations 40 | ======================== 41 | 42 | .. code:: haskell 43 | 44 | module Models.User 45 | ( 46 | module Models.User 47 | , module Models.User.Types 48 | , module Autogenerated.Models.User 49 | ) where 50 | 51 | instance DbModel User where 52 | strictValidations :: (MonadIO m) => User -> m [Error] 53 | strictValidations user = 54 | (validateUnique "Email must be unique" email) 55 | <> (validateLength "Name must be between 5 and 100 chars" (5, 100) name) 56 | <> (validateFormat "Doesn't seem like a valid email." (compiledRegex "(.*)@(.*)\.(.*)") email) 57 | <> (validatePresence "Name should be present" name) -- strips the field of whitespace 58 | <> (validateIn "Should be one of black or gray" ["black", "gray"] colourCode) 59 | <> (if (present $ user ^. firstName) 60 | then (validatePresence "Last name should be present if first name is given" lastName) 61 | else []) 62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /doc/docs/opaleye/code/instant-gratification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE Arrows #-} 2 | module Main where 3 | 4 | import Opaleye 5 | import Database.PostgreSQL.Simple 6 | import Data.Profunctor.Product (p3) 7 | import Control.Arrow 8 | 9 | userTable :: Table 10 | (Column PGInt4, Column PGText, Column PGText) -- read type 11 | (Column PGInt4, Column PGText, Column PGText) -- write type 12 | userTable = Table "users" (p3 (required "id", 13 | required "name", 14 | required "email")) 15 | 16 | 17 | selectAllRows :: Connection -> IO [(Int, String, String)] 18 | selectAllRows conn = runQuery conn $ queryTable userTable 19 | 20 | insertRow :: Connection -> (Int, String, String) -> IO () 21 | insertRow conn row = do 22 | runInsertMany conn userTable [(constant row)] 23 | return () 24 | 25 | selectByEmail :: Connection -> String -> IO [(Int, String, String)] 26 | selectByEmail conn email = runQuery conn $ proc () -> 27 | do 28 | row@(_, _, em) <- queryTable userTable -< () 29 | restrict -< (em .== constant email) 30 | returnA -< row 31 | 32 | updateRow :: Connection -> (Int, String, String) -> IO () 33 | updateRow conn row@(key, name, email) = do 34 | runUpdate 35 | conn 36 | userTable 37 | (\_ -> constant row) -- what should the matching row be updated to 38 | (\ (k, _, _) -> k .== constant key) -- which rows to update? 39 | return () 40 | 41 | main :: IO () 42 | main = do 43 | conn <- connect ConnectInfo{connectHost="localhost" 44 | ,connectPort=5432 45 | ,connectDatabase="opaleye_tutorial" 46 | ,connectPassword="opalaye_tutorial" 47 | ,connectUser="opaleye_tutorial" 48 | } 49 | 50 | allRows <- selectAllRows conn 51 | print allRows 52 | 53 | insertRow conn (4, "Saurabh", "saurabhnanda@gmail.com") 54 | 55 | row <- selectByEmail conn "saurabhnanda@gmail.com" 56 | print row 57 | 58 | updateRow conn (4, "Don", "corleone@puzo.com") 59 | 60 | allRows <- selectAllRows conn 61 | print allRows 62 | 63 | return () 64 | -------------------------------------------------------------------------------- /doc/docs/opaleye/code/opaleye-enums-handling.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE Arrows #-} 6 | 7 | module Main where 8 | 9 | import Opaleye 10 | import Data.Profunctor.Product 11 | import Data.Profunctor.Product.Default 12 | import Data.Profunctor.Product.TH (makeAdaptorAndInstance) 13 | 14 | import Database.PostgreSQL.Simple 15 | import Database.PostgreSQL.Simple.FromField (FromField(..), returnError, ResultError(..), Conversion) 16 | 17 | import Prelude hiding (id) 18 | import Control.Arrow 19 | 20 | data UserType = SuperAdmin | Admin | Registered deriving (Show) 21 | 22 | newtype UserId = UserId Int deriving (Show) 23 | 24 | data UserPoly id name email utype = User { id :: id, name :: name, email :: email, utype :: utype } deriving (Show) 25 | 26 | type User = UserPoly UserId String String UserType 27 | type UserPGW = UserPoly (Column PGInt4) (Column PGText) (Column PGText) (Column PGText) 28 | type UserPGR = UserPoly (Column PGInt4) (Column PGText) (Column PGText) (Column PGText) 29 | 30 | $(makeAdaptorAndInstance "pUser" ''UserPoly) 31 | 32 | userTable :: Table UserPGW UserPGR 33 | userTable = Table "typed_users" (pUser User { 34 | id = required "id", 35 | name = required "name", 36 | email = required "email", 37 | utype = required "user_type" 38 | } 39 | ) 40 | 41 | instance FromField UserId where 42 | fromField field bs = UserId <$> fromField field bs 43 | 44 | instance QueryRunnerColumnDefault PGInt4 UserId where 45 | queryRunnerColumnDefault = fieldQueryRunnerColumn 46 | 47 | instance FromField UserType where 48 | fromField field bs = utConversion $ fromField field bs 49 | where 50 | utConversion :: Conversion String -> Conversion UserType 51 | utConversion cString = do 52 | typeString <- cString 53 | case mkUserType typeString of 54 | Nothing -> returnError ConversionFailed field "Unrecognized user type" 55 | Just ut -> return ut 56 | mkUserType :: String -> Maybe UserType 57 | mkUserType "superadmin" = Just SuperAdmin 58 | mkUserType "admin" = Just Admin 59 | mkUserType "registered" = Just Registered 60 | mkUserType _ = Nothing 61 | 62 | instance QueryRunnerColumnDefault PGText UserType where 63 | queryRunnerColumnDefault = fieldQueryRunnerColumn 64 | 65 | getUserRows :: IO [User] 66 | getUserRows = do 67 | conn <- connect defaultConnectInfo { connectDatabase = "scratch"} 68 | runQuery conn $ proc () -> 69 | do 70 | user <- queryTable userTable -< () 71 | returnA -< user 72 | 73 | main :: IO () 74 | main = do 75 | rows <- getUserRows 76 | putStrLn $ show rows 77 | -------------------------------------------------------------------------------- /doc/docs/opaleye/code/opaleye-select-basic-with-records.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | 6 | module Main where 7 | 8 | import Opaleye 9 | import Data.Profunctor.Product 10 | import Data.Profunctor.Product.Default 11 | import Data.Profunctor.Product.TH (makeAdaptorAndInstance) 12 | 13 | import Database.PostgreSQL.Simple 14 | import Database.PostgreSQL.Simple.FromField (FromField(..)) 15 | 16 | import Prelude hiding (id) 17 | 18 | newtype UserId = UserId Int deriving (Show) 19 | 20 | data UserPoly id name email = User { id :: id, name :: name, email :: email } deriving (Show) 21 | 22 | type User = UserPoly UserId String String 23 | type UserPGW = UserPoly (Column PGInt4) (Column PGText) (Column PGText) 24 | type UserPGR = UserPoly (Column PGInt4) (Column PGText) (Column PGText) 25 | 26 | $(makeAdaptorAndInstance "pUser" ''UserPoly) 27 | 28 | userTable :: Table UserPGW UserPGR 29 | userTable = Table "users" (pUser User { 30 | id = required "id", 31 | name = required "name", 32 | email = required "email" 33 | } 34 | ) 35 | 36 | instance FromField UserId where 37 | fromField field bs = UserId <$> fromField field bs 38 | 39 | instance QueryRunnerColumnDefault PGInt4 UserId where 40 | queryRunnerColumnDefault = fieldQueryRunnerColumn 41 | 42 | getUserRows :: IO [User] 43 | getUserRows = do 44 | conn <- connect defaultConnectInfo { connectDatabase = "scratch"} 45 | runQuery conn $ queryTable userTable 46 | 47 | main :: IO () 48 | main = do 49 | rows <- getUserRows 50 | putStrLn $ show rows 51 | 52 | -- Output 53 | -- [User {id = UserId 1, name = "John", email = "john@mail.com"},User {id = UserId 54 | -- 2, name = "Bob", email = "bob@mail.com"},User {id = UserId 3, name = "Alice", 55 | -- email = "alice@mail.com"}] 56 | -------------------------------------------------------------------------------- /doc/docs/opaleye/code/opaleye-select-basic.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Opaleye 4 | import Data.Profunctor.Product (p3) 5 | 6 | import Database.PostgreSQL.Simple 7 | 8 | userTable :: Table 9 | (Column PGInt4, Column PGText, Column PGText) 10 | (Column PGInt4, Column PGText, Column PGText) 11 | userTable = Table "users" (p3 ( 12 | required "id", 13 | required "name", 14 | required "email" 15 | )) 16 | 17 | getUserRows :: IO [(Int, String, String)] 18 | getUserRows = do 19 | conn <- connect defaultConnectInfo { connectDatabase = "scratch"} 20 | runQuery conn $ queryTable userTable 21 | 22 | main :: IO () 23 | main = do 24 | rows <- getUserRows 25 | putStrLn $ show rows 26 | 27 | -- Output 28 | -- >main 29 | -- [(1,"John","john@mail.com"),(2,"Bob","bob@mail.com"),(3,"Alice","alic 30 | -- e@mail.com")] 31 | -------------------------------------------------------------------------------- /doc/docs/opaleye/code/opaleye-select-custom-datatype-row.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | module Main where 4 | 5 | import Opaleye 6 | import Data.Profunctor.Product (p3) 7 | import Data.Profunctor.Product.Default 8 | 9 | import Database.PostgreSQL.Simple 10 | import Database.PostgreSQL.Simple.FromField (FromField(..)) 11 | 12 | userTable :: Table 13 | (Column PGInt4, Column PGText, Column PGText) 14 | (Column PGInt4, Column PGText, Column PGText) 15 | userTable = Table "users" (p3 ( 16 | required "id", 17 | required "name", 18 | required "email" 19 | )) 20 | 21 | newtype UserId = UserId Int deriving (Show) 22 | 23 | instance FromField UserId where 24 | fromField field bs = UserId <$> fromField field bs 25 | 26 | instance QueryRunnerColumnDefault PGInt4 UserId where 27 | queryRunnerColumnDefault = fieldQueryRunnerColumn 28 | 29 | data User = User { id :: UserId, name :: String, email :: String } deriving (Show) 30 | 31 | makeUserFromTuple :: (Int, String, String) -> User 32 | makeUserFromTuple (id_, name_, e_mail) = User (UserId id_) name_ e_mail 33 | 34 | instance Default QueryRunner (Column PGInt4, Column PGText, Column PGText) User where 35 | def = makeUserFromTuple <$> def 36 | 37 | getUserRows :: IO [User] 38 | getUserRows = do 39 | conn <- connect defaultConnectInfo { connectDatabase = "scratch"} 40 | runQuery conn $ queryTable userTable 41 | 42 | main :: IO () 43 | main = do 44 | rows <- getUserRows 45 | putStrLn $ show rows 46 | 47 | -- Output 48 | -- >main 49 | -- [User {id = UserId 1, name = "John", email = "john@mail.com"}, 50 | -- User {id = UserId 2, name = "Bob", email = "bob@mail.com"}, 51 | -- User {id = UserId 3, name = "Alice", email = "alice@mail.com"}] 52 | -------------------------------------------------------------------------------- /doc/docs/opaleye/code/opaleye-select-custom-datatype.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | module Main where 3 | 4 | import Opaleye 5 | import Data.Profunctor.Product (p3) 6 | 7 | import Database.PostgreSQL.Simple 8 | import Database.PostgreSQL.Simple.FromField 9 | 10 | userTable :: Table 11 | (Column PGInt4, Column PGText, Column PGText) 12 | (Column PGInt4, Column PGText, Column PGText) 13 | userTable = Table "users" (p3 ( 14 | required "id", 15 | required "name", 16 | required "email" 17 | )) 18 | 19 | newtype UserId = UserId Int deriving (Show) 20 | 21 | instance FromField UserId where 22 | fromField field bs = UserId <$> fromField field bs 23 | 24 | instance QueryRunnerColumnDefault PGInt4 UserId where 25 | queryRunnerColumnDefault = fieldQueryRunnerColumn 26 | 27 | getUserRows :: IO [(UserId, String, String)] 28 | getUserRows = do 29 | conn <- connect defaultConnectInfo { connectDatabase = "scratch"} 30 | runQuery conn $ queryTable userTable 31 | 32 | main :: IO () 33 | main = do 34 | rows <- getUserRows 35 | putStrLn $ show rows 36 | 37 | -- Output 38 | -- >main 39 | -- [(UserId 1,"John","john@mail.com"),(UserId 2,"Bob","bob@mail.com"),(U 40 | -- serId 3,"Alice","alice@mail.com")] 41 | -------------------------------------------------------------------------------- /doc/docs/opaleye/code/opaleye-select-with-condition.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE Arrows #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | 6 | module Main where 7 | 8 | import Opaleye 9 | import Data.Profunctor.Product (p3) 10 | import Data.Profunctor.Product.Default 11 | 12 | import Database.PostgreSQL.Simple 13 | import Database.PostgreSQL.Simple.FromField (FromField(..)) 14 | 15 | import Control.Arrow 16 | 17 | userTable :: Table 18 | (Column PGInt4, Column PGText, Column PGText) 19 | (Column PGInt4, Column PGText, Column PGText) 20 | userTable = Table "users" (p3 ( 21 | required "id", 22 | required "name", 23 | required "email" 24 | )) 25 | 26 | newtype UserId = UserId Int deriving (Show) 27 | 28 | instance FromField UserId where 29 | fromField field bs = UserId <$> fromField field bs 30 | 31 | instance QueryRunnerColumnDefault PGInt4 UserId where 32 | queryRunnerColumnDefault = fieldQueryRunnerColumn 33 | 34 | data User = User { id :: UserId, name :: String, email :: String } deriving (Show) 35 | 36 | makeUserFromTuple :: (Int, String, String) -> User 37 | makeUserFromTuple (id_, name_, e_mail) = User (UserId id_) name_ e_mail 38 | 39 | instance Default QueryRunner (Column PGInt4, Column PGText, Column PGText) User where 40 | def = makeUserFromTuple <$> def 41 | 42 | getUserRows :: IO [User] 43 | getUserRows = do 44 | conn <- connect defaultConnectInfo { connectDatabase = "scratch"} 45 | runQuery conn $ proc () -> 46 | do 47 | user@(_, pgName, _) <- queryTable userTable -< () 48 | restrict -< (pgName .== (pgStrictText "John")) 49 | returnA -< user 50 | 51 | main :: IO () 52 | main = do 53 | rows <- getUserRows 54 | putStrLn $ show rows 55 | 56 | -- Output 57 | -- >main 58 | -- [User {id = UserId 1, name = "John", email = "john@mail.com"}] 59 | -------------------------------------------------------------------------------- /doc/docs/opaleye/code/opaleye-select-with-records-and-restrict.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE Arrows #-} 6 | 7 | module Main where 8 | 9 | import Opaleye 10 | import Data.Profunctor.Product 11 | import Data.Profunctor.Product.Default 12 | import Data.Profunctor.Product.TH (makeAdaptorAndInstance) 13 | 14 | import Database.PostgreSQL.Simple 15 | import Database.PostgreSQL.Simple.FromField (FromField(..)) 16 | 17 | import Prelude hiding (id) 18 | import Control.Arrow 19 | 20 | newtype UserId = UserId Int deriving (Show) 21 | 22 | data UserPoly id name email = User { id :: id, name :: name, email :: email } deriving (Show) 23 | 24 | type User = UserPoly UserId String String 25 | type UserPGW = UserPoly (Column PGInt4) (Column PGText) (Column PGText) 26 | type UserPGR = UserPoly (Column PGInt4) (Column PGText) (Column PGText) 27 | 28 | $(makeAdaptorAndInstance "pUser" ''UserPoly) 29 | 30 | userTable :: Table UserPGW UserPGR 31 | userTable = Table "users" (pUser User { 32 | id = required "id", 33 | name = required "name", 34 | email = required "email" 35 | } 36 | ) 37 | 38 | instance FromField UserId where 39 | fromField field bs = UserId <$> fromField field bs 40 | 41 | instance QueryRunnerColumnDefault PGInt4 UserId where 42 | queryRunnerColumnDefault = fieldQueryRunnerColumn 43 | 44 | getUserRows :: IO [User] 45 | getUserRows = do 46 | conn <- connect defaultConnectInfo { connectDatabase = "scratch"} 47 | runQuery conn $ proc () -> 48 | do 49 | user@User {name = pgName} <- queryTable userTable -< () 50 | restrict -< (pgName .== (pgStrictText "John")) 51 | returnA -< user 52 | 53 | main :: IO () 54 | main = do 55 | rows <- getUserRows 56 | putStrLn $ show rows 57 | 58 | -- Output 59 | -- [User {id = UserId 1, name = "John", email = "john@mail.com"},User {id = UserId 60 | -- 2, name = "Bob", email = "bob@mail.com"},User {id = UserId 3, name = "Alice", 61 | -- email = "alice@mail.com"}] 62 | -------------------------------------------------------------------------------- /doc/docs/opaleye/inserting-rows.rst: -------------------------------------------------------------------------------- 1 | .. _inserting_rows: 2 | 3 | Inserting rows 4 | ============== 5 | 6 | SQL for table creation 7 | ---------------------- 8 | 9 | We'll stick with the same ``tenants`` table as the previous chapter: 10 | 11 | .. code-block:: sql 12 | 13 | -- 14 | -- Tenants 15 | -- 16 | 17 | create type tenant_status as enum('active', 'inactive', 'new'); 18 | create table tenants( 19 | id serial primary key 20 | ,created_at timestamp with time zone not null default current_timestamp 21 | ,updated_at timestamp with time zone not null default current_timestamp 22 | ,name text not null 23 | ,first_name text not null 24 | ,last_name text not null 25 | ,email text not null 26 | ,phone text not null 27 | ,status tenant_status not null default 'inactive' 28 | ,owner_id integer 29 | ,backoffice_domain text not null 30 | constraint ensure_not_null_owner_id check (status!='active' or owner_id is not null) 31 | ); 32 | create unique index idx_index_owner_id on tenants(owner_id); 33 | create index idx_status on tenants(status); 34 | create index idx_tenants_created_at on tenants(created_at); 35 | create index idx_tenants_updated_at on tenants(updated_at); 36 | create unique index idx_unique_tenants_backoffice_domain on tenants(lower(backoffice_domain)); 37 | 38 | Inserting rows 39 | -------------- 40 | 41 | TODO 42 | 43 | - Quick example of inserting a new row into the ``tenants`` table using ``runInsertMany`` 44 | - Explanation of the code and how it corresponds to the type-signature of ``runInsertMany`` 45 | 46 | 47 | Getting the ID of a newly inserted row 48 | -------------------------------------- 49 | 50 | TODO 51 | 52 | - Quick example of inserting a new row into the ``tenants`` table and getting back the ID 53 | - Explanation of the type-signature of ``runInsertManyReturning`` API call 54 | - Showing the actual SQL queries being executed in the background 55 | 56 | Three functions missing from the Opaleye API 57 | -------------------------------------------- 58 | 59 | TODO: Recommended functions for the following two common operations: 60 | 61 | - Inserting a row using Haskell types as input (as against the PG type as input) 62 | - Inserting a single row and getting back the newly inserted ID 63 | - Inserting a single row and getting back the newly inserted row 64 | 65 | 66 | Dealing with errors 67 | ------------------- 68 | 69 | TODO: 70 | 71 | - What happens when an insert fails at the DB level, eg. a ``CHECK CONSTRAINT`` prevents insertion? 72 | - Take the example of ``idx_unique_tenants_backoffice_domain`` 73 | 74 | 75 | Using a different record-type for INSERTs 76 | ----------------------------------------- 77 | 78 | TODO 79 | 80 | - Example of defining and using a ``NewTenant`` type for row creation 81 | - Commentary on why this could be useful 82 | - Link-off to a later section which discusses these design decisions in detail - "Designing a domain API using Opaleye" 83 | -------------------------------------------------------------------------------- /doc/docs/opaleye/opaleye.rst: -------------------------------------------------------------------------------- 1 | .. Haskell Tutorials documentation master file, created by 2 | sphinx-quickstart on Thu Nov 24 09:36:10 2016. 3 | You can adapt this file completely to your liking, but it should at least 4 | contain the root `toctree` directive. 5 | 6 | Opaleye Tutorials 7 | ================= 8 | 9 | Contents: 10 | 11 | .. toctree:: 12 | :maxdepth: 2 13 | 14 | instant-gratification 15 | basic-db-mapping 16 | advanced-db-mapping 17 | selecting-rows 18 | inserting-rows 19 | updating-rows -------------------------------------------------------------------------------- /doc/docs/opaleye/selecting-rows.rst: -------------------------------------------------------------------------------- 1 | .. _selecting_rows: 2 | 3 | Selecting rows 4 | ============== 5 | 6 | TODO 7 | -------------------------------------------------------------------------------- /doc/docs/opaleye/updating-rows.rst: -------------------------------------------------------------------------------- 1 | .. _updating_rows: 2 | 3 | Updating rows 4 | ============== 5 | 6 | SQL for table creation 7 | ---------------------- 8 | 9 | We'll stick with the same ``tenants`` table as the previous chapter: 10 | 11 | .. code-block:: sql 12 | 13 | -- 14 | -- Tenants 15 | -- 16 | 17 | create type tenant_status as enum('active', 'inactive', 'new'); 18 | create table tenants( 19 | id serial primary key 20 | ,created_at timestamp with time zone not null default current_timestamp 21 | ,updated_at timestamp with time zone not null default current_timestamp 22 | ,name text not null 23 | ,first_name text not null 24 | ,last_name text not null 25 | ,email text not null 26 | ,phone text not null 27 | ,status tenant_status not null default 'inactive' 28 | ,owner_id integer 29 | ,backoffice_domain text not null 30 | constraint ensure_not_null_owner_id check (status!='active' or owner_id is not null) 31 | ); 32 | create unique index idx_index_owner_id on tenants(owner_id); 33 | create index idx_status on tenants(status); 34 | create index idx_tenants_created_at on tenants(created_at); 35 | create index idx_tenants_updated_at on tenants(updated_at); 36 | create unique index idx_unique_tenants_backoffice_domain on tenants(lower(backoffice_domain)); 37 | 38 | --- 39 | --- Products 40 | --- 41 | 42 | create type product_type as enum('physical', 'digital'); 43 | create table products( 44 | id serial primary key 45 | ,created_at timestamp with time zone not null default current_timestamp 46 | ,updated_at timestamp with time zone not null default current_timestamp 47 | ,tenant_id integer not null references tenants(id) 48 | ,name text not null 49 | ,description text 50 | ,url_slug text not null 51 | ,tags text[] not null default '{}' 52 | ,currency char(3) not null 53 | ,advertised_price numeric not null 54 | ,comparison_price numeric not null 55 | ,cost_price numeric 56 | ,type product_type not null 57 | ,is_published boolean not null default false 58 | ,properties jsonb 59 | ); 60 | create unique index idx_products_name on products(tenant_id, lower(name)); 61 | create unique index idx_products_url_sluf on products(tenant_id, lower(url_slug)); 62 | create index idx_products_created_at on products(created_at); 63 | create index idx_products_updated_at on products(updated_at); 64 | create index idx_products_comparison_price on products(comparison_price); 65 | create index idx_products_tags on products using gin(tags); 66 | create index idx_product_type on products(type); 67 | create index idx_product_is_published on products(is_published); 68 | 69 | 70 | Updating rows 71 | -------------- 72 | 73 | TODO 74 | 75 | - Quick example of selecting a single row by PK, changing a field, and updating it back, using ``runUpdate`` 76 | - Explanation of the code and how it corresponds to the type-signature of ``runUpdate`` 77 | 78 | 79 | Getting the updated rows back from the DB 80 | ----------------------------------------- 81 | 82 | TODO 83 | 84 | - Quick example of updating multiple rows in the ``products`` table and getting back the updated rows 85 | - Explanation of the type-signature of ``runUpdateReturning`` API call 86 | - Show the actual SQL queries being executed in the background 87 | 88 | Commentary on Opaleye's update APIs 89 | ----------------------------------- 90 | 91 | TODO: 92 | 93 | - Opaleye forces you to update every single column in the row being updated. Why is this? 94 | 95 | Multi-table updates (updates with JOINs) 96 | ---------------------------------------- 97 | 98 | TODO: Does Opaleye even support them? If not, what's the escape hatch? 99 | -------------------------------------------------------------------------------- /doc/docs/reflex/img/starterApp.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/doc/docs/reflex/img/starterApp.png -------------------------------------------------------------------------------- /doc/docs/reflex/outline.rst: -------------------------------------------------------------------------------- 1 | .. _outline 2 | 3 | An outline of the tutorials 4 | =========================== 5 | 6 | This tutorial will be a progressive installment on how to write more and more 7 | complex reflex apps; Each major section will have a companion repo that you can 8 | install and use to learn the concepts we're presenting. 9 | 10 | First Part: How to get started 11 | ------------------------------ 12 | 13 | Here we'll cover how to build, and minify an example app (commands, cabal flags, 14 | etc). From the code perspective, the code is slightly more complex than the one 15 | in the author's reflex tutorial, offering a first example of a more complex 16 | interaction of signals. 17 | 18 | Companion repo: `starterApp `_ 19 | 20 | Second Part: Client-Server structure and validations 21 | ---------------------------------------------------- 22 | 23 | Here we'll see how to write an application with a server and a client part, 24 | doing a simple authentication of a form. 25 | 26 | * How to organize a project with a common part shared between backend and 27 | frontend. 28 | 29 | * A simple server, handling the requests for authentication and using wai to 30 | gzip the js he's sending. 31 | 32 | * Servant integration: how to treat communication with server in the reflex 33 | network (and calculate the reflex functions directly from the API 34 | specification). 35 | 36 | * A general take on validation, showing how to mix validations on the client and 37 | on the server side. 38 | 39 | Companion repo: `mockLoginPage `_, corresponding to the mockup `here `_. 40 | 41 | 42 | Third Part: Large scale structure of the app, JSX templating 43 | ------------------------------------------------------------ 44 | 45 | Here we'll show how to write a multi-page app complete with routing, jsx 46 | templating, hiding of signals with EventWriter, and we'll share a simple case of 47 | ffi binding. 48 | 49 | * Descriving the problem we're solving with reflex-jsx and the solution 50 | * Global app structuring 51 | * Routing with servant-router and reflex-contrib-router 52 | * An example of advanced widget creation 53 | * EventWriter and the related advantages in the link structure 54 | * The global interceptor-like feature 55 | * FFI bindings 56 | * Comments on Reflex Ecosystem 57 | 58 | Companion repo: `mockUsersRoles `_, corresponding to the mockup `here `_ and related. 59 | -------------------------------------------------------------------------------- /doc/docs/reflex/reflex.rst: -------------------------------------------------------------------------------- 1 | .. Haskell Tutorials documentation master file, created by 2 | Carlo Nucera on Thu Nov 24 09:36:10 2016. 3 | You can adapt this file completely to your liking, but it should at least 4 | contain the root `toctree` directive. 5 | 6 | Reflex Tutorials 7 | ================ 8 | 9 | Contents: 10 | 11 | .. toctree:: 12 | :maxdepth: 2 13 | 14 | outline 15 | getting-started 16 | a-server-client-architecture 17 | -------------------------------------------------------------------------------- /doc/docs/relational-record/advanced-db-mapping.rst: -------------------------------------------------------------------------------- 1 | Advanced DB mapping 2 | ==================== 3 | 4 | [HRR is DB agnostic, meaning that user defined types or extensions are not supported, by choice of HRRs authors. 5 | This chapter should give an overview how to approach that topic] 6 | 7 | [This chapter includes a view on how HRR interoperates with postgres additions to the SQL standard] 8 | 9 | 10 | date/time types 11 | --------------- 12 | 13 | [how are date/time values mapped by HRR? is there any special way necessary to deal with them?] 14 | 15 | 16 | JSON(B) type 17 | ------------ 18 | 19 | [Show how a patched HRR library can derive JSON(B) as ByteString but provides 20 | no abstraction for it in its query syntax (like cf. https://www.postgresql.org/docs/9.5/static/functions-json.html)] 21 | 22 | 23 | Enums 24 | ----- 25 | 26 | [Show how with some TH magic you can use HRRs data type derivation to actually 27 | generate Haskell sum types and HRR projections from postgres enums, so that 28 | this feature becomes usable quite well] 29 | 30 | 31 | Arrays 32 | ------ 33 | 34 | [There are yet some experiments to do here on how to best deal with 35 | postgres arrays, e.g. parse the literals into Haskell lists with 36 | custom FromSql / ToSql instances - in short, proof of concept still missing] 37 | 38 | 39 | Type Alias 40 | ---------- 41 | 42 | [Is it possible to use a type alias on the DB and generate a mapping to a Haskell 43 | newtype, for additional type safety?] 44 | -------------------------------------------------------------------------------- /doc/docs/relational-record/advanced-workflow.rst: -------------------------------------------------------------------------------- 1 | 2 | Advanced Workflow 3 | ================== 4 | 5 | 6 | DB-side constraints / data validation 7 | ------------------------------------ 8 | 9 | [explain how (sadly) HRR can't capture a DB constraint as a Haskell function for validation; only flat data type derivation] 10 | 11 | 12 | Joins 13 | ----- 14 | 15 | [explain examples utilizing various kinds of joins in HRR] 16 | 17 | 18 | Subqueries 19 | ---------- 20 | 21 | [provide examples of subselects] 22 | 23 | 24 | Union, Coalesce 25 | --------------- 26 | 27 | [check if HRR supports these expressions, if so, give examples] 28 | 29 | 30 | Case ... when 31 | ------------- 32 | 33 | [check if HRR supports that expression, if so, give an example] 34 | 35 | 36 | Functions 37 | --------- 38 | 39 | [Say something about functions like e.g. char_length(), date_part(), ...] 40 | 41 | 42 | Housekeeping 43 | ------------ 44 | 45 | [how to deal with housekeeping columns, like timestamps] 46 | 47 | 48 | Fallback to HDBC 49 | ---------------- 50 | 51 | [being based on HDBC, you can have a fallback when doing something 52 | with the DB that HRRs abstractions don't cover, like e.g. select the 53 | last inserted PK or do INSERT ... RETURNING *] 54 | 55 | 56 | 57 | Bulk inserting / preparing statements 58 | ------------------------------------- 59 | 60 | [as before, this stuff has to be done one level below HRRs abstraction; HRR 61 | does not provide any mechanism for these cases] 62 | -------------------------------------------------------------------------------- /doc/docs/relational-record/basic-db-mapping.rst: -------------------------------------------------------------------------------- 1 | Basic DB mapping 2 | ================= 3 | 4 | [Data type derivation being a pivotal point of HRR, explain more in detail 5 | what HRR does at compile time and what the result looks like] 6 | 7 | 8 | Full example 9 | ------------ 10 | 11 | [Take a table like e.g. users and explain all the stuff HRR generates via Template Haskell: 12 | the record data type, selectors, projections, and a basic relation that is equivalent to SELECT * FROM] 13 | 14 | 15 | Projections 16 | ----------- 17 | 18 | [Explain HRRs projections (:: Pi a b) and what they're useful for] 19 | 20 | 21 | TypeMap 22 | -------- 23 | 24 | [How to tell HRR to use custom type mappings, like mappings to different 25 | Haskell string/text or numeric types] 26 | -------------------------------------------------------------------------------- /doc/docs/relational-record/basic-workflow.rst: -------------------------------------------------------------------------------- 1 | 2 | CRUD workflow in HRR 3 | ===================== 4 | 5 | [This chapter is about the basic DB operations, with Haskell code examples; 6 | special attention must be given here to how parametrized queries are defined 7 | as well as the placeholder syntax HRR employs] 8 | 9 | Select 10 | ------ 11 | 12 | 13 | Insert 14 | ------ 15 | 16 | 17 | Update 18 | ------ 19 | 20 | 21 | Delete 22 | ------ 23 | 24 | 25 | Where clauses 26 | ------------- 27 | [illustrate some examples of clauses with comparison operators and boolean 28 | expressions, e.g. IN, LIKE and such] 29 | 30 | 31 | [This chapter should cover the Haskell-side syntax of HRRs query DSL] 32 | -------------------------------------------------------------------------------- /doc/docs/relational-record/relational-record-intro.rst: -------------------------------------------------------------------------------- 1 | Introduction 2 | ============================== 3 | 4 | What is Haskell Relational Record? 5 | ---------------------------------- 6 | 7 | [Definition of HRR, presenting its way of abstraction; Motivation for it as a framework] 8 | 9 | 10 | What HRR is not 11 | ---------------- 12 | 13 | [Explain difference from Object-Relational-Mappers like Persistent, or other query generators like Opaleye] 14 | 15 | 16 | How does it work 17 | ----------------- 18 | 19 | [Dip into HRRs template Haskell data type derivation system; show, how relations defined in Haskell are rendered as SQL] 20 | 21 | (How detailed should this paragraph be?) 22 | -------------------------------------------------------------------------------- /doc/docs/relational-record/relational-record.rst: -------------------------------------------------------------------------------- 1 | 2 | 3 | Haskell Relational Record Tutorials 4 | =================================== 5 | 6 | Contents: 7 | 8 | .. toctree:: 9 | :maxdepth: 2 10 | 11 | instant-gratification 12 | relational-record-intro 13 | basic-db-mapping 14 | basic-workflow 15 | advanced-db-mapping 16 | advanced-workflow 17 | summary-conclusion 18 | -------------------------------------------------------------------------------- /doc/docs/relational-record/summary-conclusion.rst: -------------------------------------------------------------------------------- 1 | Summary and Conclusion 2 | ======================== 3 | 4 | 5 | Why and when you should use HRR in a live system 6 | -------------------------------------------------- 7 | 8 | [Describe what use scenario HRRs handles best; outline the benefits: 9 | type safety of queries defined in Haskell and type checking of queries against the DB schema; avoiding boilerplate] 10 | 11 | 12 | Drawbacks you might be in for 13 | ------------------------------ 14 | 15 | [HRRs limitation to the base cases, as per decision of the authors; sometimes clumsy 16 | syntax; need for a complete and running DB backend to build Haskell project; 17 | while HRR entry-level docs are quite good, lack of mid-level documentation 18 | and reference examples becomes obvious later on] 19 | 20 | 21 | Integration 22 | ----------- 23 | 24 | [To live up to the promise of type-safety, a change in the underlying DB schema 25 | must be reflected when (re)building a Haskell project which uses HRR. Say something 26 | about how HRR can be integrated with a build system like stack so that data types 27 | get derived anew in their respective Haskell modules when necessary] 28 | -------------------------------------------------------------------------------- /doc/hakyll/README.md: -------------------------------------------------------------------------------- 1 | # Content Outline 2 | 3 | * Philosophy and guiding principles behind the libraries 4 | * Opaleye 5 | * HRR 6 | * Persistent 7 | * Setting up basic DB mappings 8 | * Non-nullable columns without DB-specified defaults 9 | * Non-nullable columns with DB-specified defaults 10 | * Nullable columns without DB-specified defaults 11 | * Nullable columns with DB-specified defaults 12 | * Opalaye 13 | * Why do we need to specify Haskell AND PG types? 14 | * Commentary on parameterized record types 15 | * Ability to represent DB rows as tuples instead of records 16 | * Persistent 17 | * Recommended way is Template Haskell 18 | * HRR 19 | * Uses TemplateHaskell to fetch the DB definition at compile-time and generate the record types 20 | * Setting up advanced DB mappings 21 | * ENUMs 22 | * Postgres arrays 23 | * JSONB 24 | * Non-integer primary keys 25 | * DSL support for other SQL stuff 26 | * Constraints (CHECK & REFERENCES) 27 | * Triggers 28 | * Opaleye 29 | * Doesn't give DSL for DDL (data definition language) commands in SQL 30 | * Persistent 31 | * How to run custom SQL in-sync with the automatic migration? 32 | * HRR 33 | * Don't know 34 | * Inserting rows 35 | * Specifying all columns in the row 36 | * Omitting certain columns and letting DB specify the default 37 | * INSERT... RETURNING ID 38 | * INSERT... RETURNING * 39 | * Insert single row 40 | * Insert multiple rows 41 | * Updating rows 42 | * Updating all columns in matching row(s) 43 | * Updating only specific columns in matching row(s) 44 | * Updates with JOINs 45 | * UPDATE... RETURNING * 46 | * Selecting rows 47 | * Simple select of single row 48 | * Fetch all columns from rows matching a condition 49 | * Fetch specific columns from rows matching a condition 50 | * Ordering 51 | * Grouping 52 | * Joins 53 | * Limit/offset 54 | * Selecting in batches (or using cursors) 55 | * Database transactions 56 | * Nested DB transactions 57 | * Managing housekeeping columns (createdAt, updatedAt) 58 | * Support for prepared statements 59 | * Any special/interesting/unique features? -------------------------------------------------------------------------------- /doc/hakyll/_site/about.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | My Hakyll Blog - About 7 | 8 | 9 | 10 | 21 | 22 |
23 |

About

24 | 25 |

Nullam imperdiet sodales orci vitae molestie. Nunc quam orci, pharetra a rhoncus vitae, eleifend id felis. Suspendisse potenti. Etiam vitae urna orci. Quisque pellentesque dignissim felis, egestas tempus urna luctus vitae. In hac habitasse platea dictumst. Morbi fringilla mattis odio, et mattis tellus accumsan vitae.

26 |
    27 |
  1. Amamus Unicode 碁
    2. 28 |
  2. Interdum nex magna.
    3. 29 |
30 |

Vivamus eget mauris sit amet nulla laoreet lobortis. Nulla in diam elementum risus convallis commodo. Cras vehicula varius dui vitae facilisis. Proin elementum libero eget leo aliquet quis euismod orci vestibulum. Duis rhoncus lorem consequat tellus vestibulum aliquam. Quisque orci orci, malesuada porta blandit et, interdum nec magna.

31 |
32 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /doc/hakyll/_site/archive.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | My Hakyll Blog - Archives 7 | 8 | 9 | 10 | 21 | 22 |
23 |

Archives

24 | 25 | Here you can find all my previous posts: 26 | 41 | 42 | 43 |
44 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /doc/hakyll/_site/contact.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | My Hakyll Blog - Contact 7 | 8 | 9 | 10 | 21 | 22 |
23 |

Contact

24 | 25 |

I live in a small hut in the mountains of Kumano Kodō on Kii Hantō and would not like to be contacted.

26 |
27 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /doc/hakyll/_site/css/default.css: -------------------------------------------------------------------------------- 1 | body{color:black;font-size:16px;margin:0px auto 0px auto;width:800px}code{font-size:14px;background:#f2f2f2;display:inline-block;padding:0px 3px}div#header{border-bottom:2px solid black;margin-bottom:30px;padding:12px 0px 12px 0px}div#logo a{color:black;float:left;font-size:18px;font-weight:bold;text-decoration:none}div#header #navigation{text-align:right}div#header #navigation a{color:black;font-size:18px;font-weight:bold;margin-left:12px;text-decoration:none;text-transform:uppercase}div#footer{border-top:solid 2px black;color:#555;font-size:12px;margin-top:30px;padding:12px 0px 12px 0px;text-align:right}h1{font-size:24px}h2{font-size:20px}div.info{color:#555;font-size:14px;font-style:italic}table{width:100% !important}table th{text-align:left;border-bottom:1px solid #333}table td{border-bottom:1px solid #ccc;vertical-align:top;padding:2px 4px;width:auto}div.sourceCode{font-size:14px;background:#f9f9f9;padding:10px;max-height:300px;overflow-y:scroll;display:block}table.sourceCode, tr.sourceCode, td.lineNumbers, td.sourceCode, table.sourceCode pre, .sourceCode{margin:0;padding:0;border:0;border:none}code.sourceCode{background:transparent;display:inline}td.lineNumbers{border-right:1px solid #AAAAAA;text-align:right;color:#AAAAAA;padding-right:5px;padding-left:5px}td.sourceCode{padding-left:5px}.sourceCode span.kw{color:#007020;font-weight:bold}.sourceCode span.dt{color:#902000}.sourceCode span.dv{color:#40a070}.sourceCode span.bn{color:#40a070}.sourceCode span.fl{color:#40a070}.sourceCode span.ch{color:#4070a0}.sourceCode span.st{color:#4070a0}.sourceCode span.co{color:#60a0b0;font-style:italic}.sourceCode span.ot{color:#007020}.sourceCode span.al{color:red;font-weight:bold}.sourceCode span.fu{color:#06287e}.sourceCode span.re{}.sourceCode span.er{color:red;font-weight:bold} -------------------------------------------------------------------------------- /doc/hakyll/_site/images/haskell-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/doc/hakyll/_site/images/haskell-logo.png -------------------------------------------------------------------------------- /doc/hakyll/_site/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | My Hakyll Blog - Home 7 | 8 | 9 | 10 | 21 | 22 |
23 |

Home

24 | 25 |

Comparing Haskell DB libraries

26 | 27 | 28 | 29 |

Welcome to my blog!

30 | 31 |

I've reproduced a list of recent posts here for your reading pleasure:

32 | 33 |

Posts

34 | 49 | 50 | 51 |

…or you can find more in the archives.

52 | 53 |
54 | 58 | 59 | 60 | -------------------------------------------------------------------------------- /doc/hakyll/_site/posts/overview.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | My Hakyll Blog - Comparison between Opaleye, Haskell Relational Record, and Persistent 7 | 8 | 9 | 10 | 21 | 22 |
23 |

Comparison between Opaleye, Haskell Relational Record, and Persistent

24 | 25 |
26 | Posted on November 23, 2016 27 | 28 |
29 | 30 |

Content outline

31 |
    32 |
  • Philosophy and guiding principles behind the libraries 33 |
      34 |
    • Opaleye
      • 35 |
    • HRR
      • 36 |
    • Persistent
      • 37 |
    • 38 |
  • Setting up basic DB mappings - Overview 39 |
      40 |
    • Opalaye
      • 41 |
    • Persistent 42 |
        43 |
      • Recommended way is Template Haskell
        • 44 |
      • 45 |
    • HRR 46 |
        47 |
      • Uses TemplateHaskell to fetch the DB definition at compile-time and generate the record types
        • 48 |
      • 49 |
    • 50 |
  • Setting up advanced DB mappings 51 |
      52 |
    • ENUMs
      • 53 |
    • Postgres arrays
      • 54 |
    • JSONB
      • 55 |
    • Non-integer primary keys
      • 56 |
    • 57 |
  • DSL support for other SQL stuff 58 |
      59 |
    • Constraints (CHECK & REFERENCES)
      • 60 |
    • Triggers
      • 61 |
    • Opaleye 62 |
        63 |
      • Doesn’t give DSL for DDL (data definition language) commands in SQL
        • 64 |
      • 65 |
    • Persistent 66 |
        67 |
      • How to run custom SQL in-sync with the automatic migration?
        • 68 |
      • 69 |
    • HRR 70 |
        71 |
      • Dont know
        • 72 |
      • 73 |
    • 74 |
  • Inserting rows 75 |
      76 |
    • Specifying all columns in the row
      • 77 |
    • Omitting certain columns and letting DB specify the default
      • 78 |
    • INSERT... RETURNING ID
      • 79 |
    • INSERT... RETURNING *
      • 80 |
    • Insert single row
      • 81 |
    • Insert multiple rows
      • 82 |
    • 83 |
  • Updating rows 84 |
      85 |
    • Updating all columns in matching row(s)
      • 86 |
    • Updating only specific columns in matching row(s)
      • 87 |
    • Updates with JOINs
      • 88 |
    • UPDATE... RETURNING *
      • 89 |
    • 90 |
  • Selecting rows 91 |
      92 |
    • Simple select of single row
      • 93 |
    • Fetch all columns from rows matching a condition
      • 94 |
    • Fetch specific columns from rows matching a condition
      • 95 |
    • Ordering
      • 96 |
    • Grouping
      • 97 |
    • Joins
      • 98 |
    • Limit/offset
      • 99 |
    • Selecting in batches (or using cursors)
      • 100 |
    • 101 |
  • Database transactions 102 |
      103 |
    • Nested DB transactions
      • 104 |
    • 105 |
  • Managing housekeeping columns (createdAt, updatedAt)
    • 106 |
  • Support for prepared statements
    • 107 |
  • Any special/interesting/unique features?
    • 108 |
109 | 110 |
111 | 115 | 116 | 117 | -------------------------------------------------------------------------------- /doc/hakyll/about.rst: -------------------------------------------------------------------------------- 1 | --- 2 | title: About 3 | --- 4 | Nullam imperdiet sodales orci vitae molestie. Nunc quam orci, pharetra a 5 | rhoncus vitae, eleifend id felis. Suspendisse potenti. Etiam vitae urna orci. 6 | Quisque pellentesque dignissim felis, egestas tempus urna luctus vitae. In hac 7 | habitasse platea dictumst. Morbi fringilla mattis odio, et mattis tellus 8 | accumsan vitae. 9 | 10 | 1. Amamus Unicode 碁 11 | 2. Interdum nex magna. 12 | 13 | Vivamus eget mauris sit amet nulla laoreet lobortis. Nulla in diam elementum 14 | risus convallis commodo. Cras vehicula varius dui vitae facilisis. Proin 15 | elementum libero eget leo aliquet quis euismod orci vestibulum. Duis rhoncus 16 | lorem consequat tellus vestibulum aliquam. Quisque orci orci, malesuada porta 17 | blandit et, interdum nec magna. 18 | -------------------------------------------------------------------------------- /doc/hakyll/contact.markdown: -------------------------------------------------------------------------------- 1 | --- 2 | title: Contact 3 | --- 4 | 5 | I live in a small hut in the mountains of Kumano Kodō on Kii Hantō and would not 6 | like to be contacted. 7 | -------------------------------------------------------------------------------- /doc/hakyll/css/default.css: -------------------------------------------------------------------------------- 1 | body { 2 | color: black; 3 | font-size: 16px; 4 | margin: 0px auto 0px auto; 5 | width: 800px; 6 | } 7 | 8 | code { 9 | font-size: 14px; 10 | background: #f2f2f2; 11 | display: inline-block; 12 | padding: 0px 3px; 13 | } 14 | 15 | div#header { 16 | border-bottom: 2px solid black; 17 | margin-bottom: 30px; 18 | padding: 12px 0px 12px 0px; 19 | } 20 | 21 | div#logo a { 22 | color: black; 23 | float: left; 24 | font-size: 18px; 25 | font-weight: bold; 26 | text-decoration: none; 27 | } 28 | 29 | div#header #navigation { 30 | text-align: right; 31 | } 32 | 33 | div#header #navigation a { 34 | color: black; 35 | font-size: 18px; 36 | font-weight: bold; 37 | margin-left: 12px; 38 | text-decoration: none; 39 | text-transform: uppercase; 40 | } 41 | 42 | div#footer { 43 | border-top: solid 2px black; 44 | color: #555; 45 | font-size: 12px; 46 | margin-top: 30px; 47 | padding: 12px 0px 12px 0px; 48 | text-align: right; 49 | } 50 | 51 | h1 { 52 | font-size: 24px; 53 | } 54 | 55 | h2 { 56 | font-size: 20px; 57 | } 58 | 59 | div.info { 60 | color: #555; 61 | font-size: 14px; 62 | font-style: italic; 63 | } 64 | 65 | table { 66 | width: 100% !important; 67 | } 68 | 69 | table th { 70 | text-align: left; 71 | border-bottom: 1px solid #333; 72 | } 73 | table td { 74 | border-bottom: 1px solid #ccc; 75 | vertical-align: top; 76 | padding: 2px 4px; 77 | width: auto; 78 | } 79 | 80 | /* Generated by pandoc. - HASKELL SYNTAX HIGHLIGHTING */ 81 | div.sourceCode { 82 | font-size: 14px; 83 | background: #f9f9f9; 84 | padding: 10px; 85 | max-height: 300px; 86 | overflow-y: scroll; 87 | display: block; 88 | } 89 | table.sourceCode, tr.sourceCode, td.lineNumbers, td.sourceCode, table.sourceCode pre, .sourceCode { 90 | margin: 0; 91 | padding: 0; 92 | border: 0; 93 | border: none; 94 | } 95 | 96 | code.sourceCode { 97 | background: transparent; 98 | display: inline; 99 | } 100 | 101 | td.lineNumbers { border-right: 1px solid #AAAAAA; text-align: right; color: #AAAAAA; padding-right: 5px; padding-left: 5px; } 102 | td.sourceCode { padding-left: 5px; } 103 | .sourceCode span.kw { color: #007020; font-weight: bold; } 104 | .sourceCode span.dt { color: #902000; } 105 | .sourceCode span.dv { color: #40a070; } 106 | .sourceCode span.bn { color: #40a070; } 107 | .sourceCode span.fl { color: #40a070; } 108 | .sourceCode span.ch { color: #4070a0; } 109 | .sourceCode span.st { color: #4070a0; } 110 | .sourceCode span.co { color: #60a0b0; font-style: italic; } 111 | .sourceCode span.ot { color: #007020; } 112 | .sourceCode span.al { color: red; font-weight: bold; } 113 | .sourceCode span.fu { color: #06287e; } 114 | .sourceCode span.re { } 115 | .sourceCode span.er { color: red; font-weight: bold; } -------------------------------------------------------------------------------- /doc/hakyll/doc.cabal: -------------------------------------------------------------------------------- 1 | name: doc 2 | version: 0.1.0.0 3 | build-type: Simple 4 | cabal-version: >= 1.10 5 | 6 | executable site 7 | main-is: site.hs 8 | build-depends: base == 4.* 9 | , hakyll == 4.8.* 10 | ghc-options: -threaded 11 | default-language: Haskell2010 12 | -------------------------------------------------------------------------------- /doc/hakyll/images/haskell-logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/doc/hakyll/images/haskell-logo.png -------------------------------------------------------------------------------- /doc/hakyll/includes/db-mappings/DB.hs: -------------------------------------------------------------------------------- 1 | module DB where 2 | 3 | import Opalaye 4 | import Data.Text 5 | import Data.Time (UTCTime) 6 | 7 | data TenantPoly key createdAt updatedAt name status ownerId backofficeDomain = Tenant { 8 | tenantKey :: key 9 | ,tenantCreatedAt :: createdAt 10 | ,tenantUpdatedAt :: updatedAt 11 | ,tenantName :: name 12 | ,tenantStatus :: status 13 | ,tenantOwnerId :: ownerId 14 | ,tenantBackofficeDomain :: backofficeDomain 15 | } deriving Show 16 | 17 | type TenantPGWrite = TenantPoly 18 | (Maybe (Column PGInt8)) -- key 19 | (Maybe (Column PGTimestamptz)) -- createdAt 20 | (Column PGTimestamptz) -- updatedAt 21 | (Column PGText) -- name 22 | (Column PGText) -- status 23 | (Column (Nullable PGInt8)) -- ownerId 24 | (Column PGText) -- backofficeDomain 25 | 26 | type TenantPGRead = TenantPoly 27 | (Column PGInt8) -- key 28 | (Column PGTimestamptz) -- createdAt 29 | (Column PGTimestamptz) -- updatedAt 30 | (Column PGText) -- name 31 | (Column PGText) -- status 32 | (Column (Nullable PGInt8)) -- ownerId 33 | (Column PGText) -- backofficeDomain 34 | 35 | type Tenant = TenantPoly 36 | Integer -- key 37 | UTCTime -- createdAt 38 | UTCTime -- updatedAt 39 | Text -- name 40 | Text -- status 41 | (Maybe Integer) -- ownerId 42 | Text -- backofficeDomain 43 | 44 | $(makeAdaptorAndInstance "pTenant" ''TenantPoly) 45 | $(makeLensesWith abbreviatedFields ''TenantPoly) 46 | 47 | 48 | tenantTable :: Table TenantPGWrite TenantPGRead 49 | tenantTable = Table "tenants" (pTenant Tenant{ 50 | tenantKey = optional "id" 51 | ,tenantCreatedAt = optional "created_at" 52 | ,tenantUpdatedAt = required "updated_at" 53 | ,tenantName = required "name" 54 | ,tenantStatus = required "status" 55 | ,tenantOwnerId = required "owner_id" 56 | ,tenantBackofficeDomain = required "backoffice_domain" 57 | }) -------------------------------------------------------------------------------- /doc/hakyll/includes/db-mappings/schema.sql: -------------------------------------------------------------------------------- 1 | -- 2 | -- Tenants 3 | -- 4 | 5 | create table tenants( 6 | id serial primary key 7 | ,created_at timestamp with time zone not null default current_timestamp 8 | ,updated_at timestamp with time zone not null default current_timestamp 9 | ,name text not null 10 | ,first_name text not null 11 | ,last_name text not null 12 | ,email text not null 13 | ,phone text not null 14 | ,status text not null default 'inactive' 15 | ,owner_id integer 16 | ,backoffice_domain text not null 17 | constraint ensure_not_null_owner_id check (status!='active' or owner_id is not null) 18 | ); 19 | create unique index idx_index_owner_id on tenants(owner_id); 20 | create index idx_status on tenants(status); 21 | create index idx_tenants_created_at on tenants(created_at); 22 | create index idx_tenants_updated_at on tenants(updated_at); 23 | create unique index idx_unique_tenants_backoffice_domain on tenants(lower(backoffice_domain)); 24 | -------------------------------------------------------------------------------- /doc/hakyll/index.html: -------------------------------------------------------------------------------- 1 | --- 2 | title: Home 3 | --- 4 | 5 |

Comparing Haskell DB libraries

6 | 7 | 8 | 9 |

Welcome to my blog!

10 | 11 |

I've reproduced a list of recent posts here for your reading pleasure:

12 | 13 |

Posts

14 | $partial("templates/post-list.html")$ 15 | 16 |

…or you can find more in the archives.

17 | -------------------------------------------------------------------------------- /doc/hakyll/posts/db-mappings-overview.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: Setting up basic Haskell<=>DB mappings 3 | date: 2016-11-23 4 | --- 5 | 6 | In this section we will configure the DB<=>Haskell mapping for the following table: 7 | 8 | * `tenants` - the master table of "tenants" in a typical multi-tenant SaaS app. You can think of a tenant as a "company account", where no two company accounts share any data. 9 | 10 | At the end of the mapping process, we would like to have a schema as close to the following, as possible. 11 | 12 | ```sql 13 | -- 14 | -- Tenants 15 | -- 16 | 17 | create table tenants( 18 | id serial primary key 19 | ,created_at timestamp with time zone not null default current_timestamp 20 | ,updated_at timestamp with time zone not null default current_timestamp 21 | ,name text not null 22 | ,first_name text not null 23 | ,last_name text not null 24 | ,email text not null 25 | ,phone text not null 26 | ,status text not null default 'inactive' 27 | ,owner_id integer 28 | ,backoffice_domain text not null 29 | constraint ensure_not_null_owner_id check (status!='active' or owner_id is not null) 30 | ); 31 | create unique index idx_index_owner_id on tenants(owner_id); 32 | create index idx_status on tenants(status); 33 | create index idx_tenants_created_at on tenants(created_at); 34 | create index idx_tenants_updated_at on tenants(updated_at); 35 | create unique index idx_unique_tenants_backoffice_domain on tenants(lower(backoffice_domain)); 36 | ``` 37 | 38 | Further, we will see how each DB library deals with the following four cases: 39 | 40 | * Non-nullable columns without DB-specified defaults 41 | * Non-nullable columns with DB-specified defaults 42 | * Nullable columns without DB-specified defaults 43 | * Nullable columns with DB-specified defaults - TODO: What's a good use-case for such a column? -------------------------------------------------------------------------------- /doc/hakyll/posts/overview.markdown: -------------------------------------------------------------------------------- 1 | --- 2 | title: Comparison between Opaleye, Haskell Relational Record, and Persistent 3 | date: 2016-11-23 4 | --- 5 | 6 | ## Content outline 7 | 8 | * Philosophy and guiding principles behind the libraries 9 | * Opaleye 10 | * HRR 11 | * Persistent 12 | * [Setting up basic DB mappings - Overview](./db-mappings-overview.html) 13 | * [Opalaye](./db-mappings-opaleye.html) 14 | * Persistent 15 | * Recommended way is Template Haskell 16 | * HRR 17 | * Uses TemplateHaskell to fetch the DB definition at compile-time and generate the record types 18 | * Setting up advanced DB mappings 19 | * ENUMs 20 | * Postgres arrays 21 | * JSONB 22 | * Non-integer primary keys 23 | * DSL support for other SQL stuff 24 | * Constraints (CHECK & REFERENCES) 25 | * Triggers 26 | * Opaleye 27 | * Doesn't give DSL for DDL (data definition language) commands in SQL 28 | * Persistent 29 | * How to run custom SQL in-sync with the automatic migration? 30 | * HRR 31 | * Dont know 32 | * Inserting rows 33 | * Specifying all columns in the row 34 | * Omitting certain columns and letting DB specify the default 35 | * `INSERT... RETURNING ID` 36 | * `INSERT... RETURNING *` 37 | * Insert single row 38 | * Insert multiple rows 39 | * Updating rows 40 | * Updating all columns in matching row(s) 41 | * Updating only specific columns in matching row(s) 42 | * Updates with JOINs 43 | * `UPDATE... RETURNING *` 44 | * Selecting rows 45 | * Simple select of single row 46 | * Fetch all columns from rows matching a condition 47 | * Fetch specific columns from rows matching a condition 48 | * Ordering 49 | * Grouping 50 | * Joins 51 | * Limit/offset 52 | * Selecting in batches (or using cursors) 53 | * Database transactions 54 | * Nested DB transactions 55 | * Managing housekeeping columns (createdAt, updatedAt) 56 | * Support for prepared statements 57 | * Any special/interesting/unique features? -------------------------------------------------------------------------------- /doc/hakyll/site.hs: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- 2 | {-# LANGUAGE OverloadedStrings #-} 3 | import Data.Monoid (mappend) 4 | import Hakyll 5 | 6 | 7 | -------------------------------------------------------------------------------- 8 | main :: IO () 9 | main = hakyll $ do 10 | match "images/*" $ do 11 | route idRoute 12 | compile copyFileCompiler 13 | 14 | match "css/*" $ do 15 | route idRoute 16 | compile compressCssCompiler 17 | 18 | match (fromList ["about.rst", "contact.markdown"]) $ do 19 | route $ setExtension "html" 20 | compile $ pandocCompiler 21 | >>= loadAndApplyTemplate "templates/default.html" defaultContext 22 | >>= relativizeUrls 23 | 24 | match "posts/**" $ do 25 | route $ setExtension "html" 26 | compile $ pandocCompiler 27 | >>= loadAndApplyTemplate "templates/post.html" postCtx 28 | >>= loadAndApplyTemplate "templates/default.html" postCtx 29 | >>= relativizeUrls 30 | 31 | create ["archive.html"] $ do 32 | route idRoute 33 | compile $ do 34 | posts <- recentFirst =<< loadAll "posts/**" 35 | let archiveCtx = 36 | listField "posts" postCtx (return posts) `mappend` 37 | constField "title" "Archives" `mappend` 38 | defaultContext 39 | 40 | makeItem "" 41 | >>= loadAndApplyTemplate "templates/archive.html" archiveCtx 42 | >>= loadAndApplyTemplate "templates/default.html" archiveCtx 43 | >>= relativizeUrls 44 | 45 | 46 | match "index.html" $ do 47 | route idRoute 48 | compile $ do 49 | posts <- recentFirst =<< loadAll "posts/**" 50 | let indexCtx = 51 | listField "posts" postCtx (return posts) `mappend` 52 | constField "title" "Home" `mappend` 53 | defaultContext 54 | 55 | getResourceBody 56 | >>= applyAsTemplate indexCtx 57 | >>= loadAndApplyTemplate "templates/default.html" indexCtx 58 | >>= relativizeUrls 59 | 60 | match "templates/*" $ compile templateBodyCompiler 61 | 62 | match "includes/*" $ compile templateCompiler 63 | 64 | 65 | -------------------------------------------------------------------------------- 66 | postCtx :: Context String 67 | postCtx = 68 | dateField "date" "%B %e, %Y" `mappend` 69 | defaultContext 70 | -------------------------------------------------------------------------------- /doc/hakyll/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-6.2 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /doc/hakyll/templates/archive.html: -------------------------------------------------------------------------------- 1 | Here you can find all my previous posts: 2 | $partial("templates/post-list.html")$ 3 | -------------------------------------------------------------------------------- /doc/hakyll/templates/default.html: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | My Hakyll Blog - $title$ 8 | 9 | 10 | 11 | 22 | 23 |
24 |

$title$

25 | 26 | $body$ 27 |
28 | 32 | 33 | 34 | -------------------------------------------------------------------------------- /doc/hakyll/templates/post-list.html: -------------------------------------------------------------------------------- 1 |
    2 | $for(posts)$ 3 |
  • 4 | $title$ - $date$ 5 |
    • 6 | $endfor$ 7 |
8 | -------------------------------------------------------------------------------- /doc/hakyll/templates/post.html: -------------------------------------------------------------------------------- 1 |
2 | Posted on $date$ 3 | $if(author)$ 4 | by $author$ 5 | $endif$ 6 |
7 | 8 | $body$ 9 | -------------------------------------------------------------------------------- /doc/index.rst: -------------------------------------------------------------------------------- 1 | .. Haskell Tutorials documentation master file, created by 2 | sphinx-quickstart on Thu Nov 24 09:36:10 2016. 3 | You can adapt this file completely to your liking, but it should at least 4 | contain the root `toctree` directive. 5 | 6 | Haskell Tutorials 7 | ================= 8 | 9 | Contents: 10 | 11 | .. toctree:: 12 | :maxdepth: 2 13 | 14 | docs/opaleye/opaleye 15 | docs/reflex/reflex 16 | docs/framework/index 17 | -------------------------------------------------------------------------------- /skeleton/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2016 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /skeleton/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /skeleton/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Lib 4 | 5 | main :: IO () 6 | main = someFunc 7 | -------------------------------------------------------------------------------- /skeleton/skeleton.cabal: -------------------------------------------------------------------------------- 1 | name: skeleton 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/githubuser/skeleton#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Author name here 9 | maintainer: example@example.com 10 | copyright: 2016 Author name here 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Lib 19 | build-depends: base >= 4.7 && < 5 20 | , text 21 | , mtl 22 | , time 23 | , transformers 24 | , bytestring 25 | , lens 26 | 27 | default-language: Haskell2010 28 | 29 | executable skeleton-exe 30 | hs-source-dirs: app 31 | main-is: Main.hs 32 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 33 | build-depends: base 34 | , skeleton 35 | default-language: Haskell2010 36 | 37 | test-suite skeleton-test 38 | type: exitcode-stdio-1.0 39 | hs-source-dirs: test 40 | main-is: Spec.hs 41 | build-depends: base 42 | , skeleton 43 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 44 | default-language: Haskell2010 45 | 46 | source-repository head 47 | type: git 48 | location: https://github.com/githubuser/skeleton 49 | -------------------------------------------------------------------------------- /skeleton/src/Domain/Auth.hs: -------------------------------------------------------------------------------- 1 | module Domain.Auth where 2 | 3 | import Import 4 | import Domain.Types 5 | 6 | authenticateUser :: Text -> Text -> AppM(Bool) 7 | authenticateUser username password = undefined 8 | 9 | -- TODO: Should the domain API be dealing with sessions? Or should it be handled 10 | -- by a layer sitting on top of Domain.Auth 11 | 12 | createSession :: Text -> Text -> AppM(SessionID) 13 | createSession username password = undefined 14 | 15 | destroySession :: SessionID -> AppM() 16 | destroySession sessid = undefined 17 | 18 | -------------------------------------------------------------------------------- /skeleton/src/Domain/Photo.hs: -------------------------------------------------------------------------------- 1 | module Domain.Photo where 2 | 3 | import Import 4 | import Domain.Types 5 | 6 | createPhoto :: ByteString -> AppM(Photo) 7 | createPhoto bstring = undefined 8 | 9 | removePhoto :: PhotoID -> AppM() 10 | remotePhoto pid = undefined 11 | 12 | getPhoto :: PhotoID -> Text -> AppM(Photo) 13 | getPhoto pid geometryOrStyle = undefined 14 | -------------------------------------------------------------------------------- /skeleton/src/Domain/Product.hs: -------------------------------------------------------------------------------- 1 | module Domain.Product where 2 | 3 | import Import 4 | import Domain.Types 5 | 6 | createProduct :: Product -> AppM(Product) 7 | createProduct product = undefined 8 | 9 | editProduct :: Product -> AppM(Product) 10 | editProduct product = undefined 11 | 12 | getProduct :: ProductID -> AppM(Product) 13 | getProduct pid = undefined 14 | 15 | 16 | data ProductFilter = ProductFilter { ids :: [ProductID] 17 | , q :: Text 18 | , title :: Text 19 | -- and more such filters can come here 20 | } 21 | filterProducts :: ProductFilter -> AppM([Product]) 22 | filterProducts pfilter = undefined 23 | -------------------------------------------------------------------------------- /skeleton/src/Domain/Role.hs: -------------------------------------------------------------------------------- 1 | module Domain.Role where 2 | 3 | import Import 4 | import Domain.Types 5 | 6 | createRole :: Role -> AppM(Role) 7 | createRole role = undefined 8 | 9 | getRole :: RoleID -> AppM(Role) 10 | getRole rid = undefined 11 | -------------------------------------------------------------------------------- /skeleton/src/Domain/Tenant.hs: -------------------------------------------------------------------------------- 1 | module Domain.Tenant where 2 | 3 | import Import 4 | import Domain.Types 5 | 6 | createTenant :: Tenant -> AppM(Tenant) 7 | createTenant tenant = undefined 8 | 9 | activateTenant :: Tenant -> Text -> AppM(Tenant) 10 | activateTenant tenant activationKey = undefined 11 | 12 | getTenant :: TenantID -> AppM(Tenant) 13 | getTenant tid = undefined 14 | 15 | -------------------------------------------------------------------------------- /skeleton/src/Domain/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Types where 3 | 4 | import Import 5 | 6 | data AppConfig = AppConfig { dbPool :: Text 7 | , redisPool :: Text 8 | } 9 | type AppM = ReaderT AppConfig 10 | 11 | type TenantID = Integer 12 | data Tenant = Tenant{} 13 | 14 | type UserID = Integer 15 | data User = User{} 16 | 17 | type ProductID = Integer 18 | data Product = Product{} 19 | 20 | type VariantID = Integer 21 | data Variant = Variant{} 22 | 23 | type PhotoID = Integer 24 | data Photo = Photo{} 25 | 26 | type RoleID = Integer 27 | data Role = Role{} 28 | 29 | type AuditLogID = Integer 30 | data AuditLog = AuditLog{} 31 | 32 | type SessionID = Text 33 | 34 | -- LENSES 35 | $(makeClassy ''AppConfig) 36 | $(makeClassy ''Tenant) 37 | $(makeClassy ''User) 38 | $(makeClassy ''Role) 39 | $(makeClassy ''Product) 40 | $(makeClassy ''Variant) 41 | $(makeClassy ''Photo) 42 | $(makeClassy ''AuditLog) 43 | -------------------------------------------------------------------------------- /skeleton/src/Domain/User.hs: -------------------------------------------------------------------------------- 1 | module Domain.User where 2 | 3 | import Import 4 | import Domain.Types 5 | 6 | createUser :: User -> AppM(User) 7 | createUser user = undefined 8 | 9 | activateUser :: User -> Text -> AppM(User) 10 | activateUser user activationKey = undefined 11 | 12 | deactivateUser :: User -> AppM(User) 13 | deactivateUser user = undefined 14 | 15 | getUser :: UserID -> AppM(User) 16 | getUser uid = undefined 17 | 18 | -------------------------------------------------------------------------------- /skeleton/src/Import.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Import( ReaderT 3 | , Text 4 | , ByteString 5 | , module Control.Lens 6 | ) where 7 | 8 | import Control.Monad.Reader (ReaderT) 9 | import Data.Text (Text) 10 | import Data.ByteString (ByteString) 11 | import Control.Lens 12 | -------------------------------------------------------------------------------- /skeleton/src/Lib.hs: -------------------------------------------------------------------------------- 1 | module Lib 2 | ( someFunc 3 | ) where 4 | 5 | someFunc :: IO () 6 | someFunc = putStrLn "someFunc" 7 | -------------------------------------------------------------------------------- /skeleton/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-7.4 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.1" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /skeleton/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /ui-mockups/assets/bootstrap/fonts/glyphicons-halflings-regular.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ui-mockups/assets/bootstrap/fonts/glyphicons-halflings-regular.eot -------------------------------------------------------------------------------- /ui-mockups/assets/bootstrap/fonts/glyphicons-halflings-regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ui-mockups/assets/bootstrap/fonts/glyphicons-halflings-regular.ttf -------------------------------------------------------------------------------- /ui-mockups/assets/bootstrap/fonts/glyphicons-halflings-regular.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ui-mockups/assets/bootstrap/fonts/glyphicons-halflings-regular.woff -------------------------------------------------------------------------------- /ui-mockups/assets/bootstrap/fonts/glyphicons-halflings-regular.woff2: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ui-mockups/assets/bootstrap/fonts/glyphicons-halflings-regular.woff2 -------------------------------------------------------------------------------- /ui-mockups/assets/css/Login-Form-Clean.css: -------------------------------------------------------------------------------- 1 | .login-clean { 2 | background:#f1f7fc; 3 | padding:80px 0; 4 | } 5 | 6 | .login-clean form { 7 | max-width:320px; 8 | width:90%; 9 | margin:0 auto; 10 | background-color:#ffffff; 11 | padding:40px; 12 | border-radius:4px; 13 | color:#505e6c; 14 | box-shadow:1px 1px 5px rgba(0,0,0,0.1); 15 | } 16 | 17 | .login-clean .illustration { 18 | text-align:center; 19 | padding:0 0 20px; 20 | font-size:100px; 21 | color:rgb(244,71,107); 22 | } 23 | 24 | .login-clean form .form-control { 25 | background:#f7f9fc; 26 | border:none; 27 | border-bottom:1px solid #dfe7f1; 28 | border-radius:0; 29 | box-shadow:none; 30 | outline:none; 31 | color:inherit; 32 | text-indent:8px; 33 | height:42px; 34 | } 35 | 36 | .login-clean form .btn-primary { 37 | background:#f4476b; 38 | border:none; 39 | border-radius:4px; 40 | padding:11px; 41 | box-shadow:none; 42 | margin-top:26px; 43 | text-shadow:none; 44 | outline:none !important; 45 | } 46 | 47 | .login-clean form .btn-primary:hover, .login-clean form .btn-primary:active { 48 | background:#eb3b60; 49 | } 50 | 51 | .login-clean form .btn-primary:active { 52 | transform:translateY(1px); 53 | } 54 | 55 | .login-clean form .forgot { 56 | display:block; 57 | text-align:center; 58 | font-size:12px; 59 | color:#6f7a85; 60 | opacity:0.9; 61 | text-decoration:none; 62 | } 63 | 64 | .login-clean form .forgot:hover, .login-clean form .forgot:active { 65 | opacity:1; 66 | text-decoration:none; 67 | } 68 | 69 | -------------------------------------------------------------------------------- /ui-mockups/assets/css/styles.css: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ui-mockups/assets/css/styles.css -------------------------------------------------------------------------------- /ui-mockups/assets/css/styles.min.css: -------------------------------------------------------------------------------- 1 | h1.page-heading{border-bottom:1px solid #ccc;margin-bottom:20px;padding-bottom:5px}a.cancel{margin-left:10px}div.secton-menu{background-color:#ffc;padding:0}.login-clean{background:#f1f7fc;padding:80px 0}.login-clean form{max-width:320px;width:90%;margin:0 auto;background-color:#fff;padding:40px;border-radius:4px;color:#505e6c;box-shadow:1px 1px 5px rgba(0,0,0,.1)}.login-clean .illustration{text-align:center;padding:0 0 20px;font-size:100px;color:#f4476b}.login-clean form .form-control{background:#f7f9fc;border:none;border-bottom:1px solid #dfe7f1;border-radius:0;box-shadow:none;outline:0;color:inherit;text-indent:8px;height:42px}.login-clean form .btn-primary{background:#f4476b;border:none;border-radius:4px;padding:11px;box-shadow:none;margin-top:26px;text-shadow:none;outline:0!important}.login-clean form .btn-primary:active,.login-clean form .btn-primary:hover{background:#eb3b60}.login-clean form .btn-primary:active{transform:translateY(1px)}.login-clean form .forgot{display:block;text-align:center;font-size:12px;color:#6f7a85;opacity:.9;text-decoration:none}.login-clean form .forgot:active,.login-clean form .forgot:hover{opacity:1;text-decoration:none}form.login-form{margin:0 auto;display:block}div.checkbox.permission-group-heading{border-bottom:1px solid #ccc;margin-bottom:15px;padding-bottom:3px} -------------------------------------------------------------------------------- /ui-mockups/assets/fonts/ionicons.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ui-mockups/assets/fonts/ionicons.eot -------------------------------------------------------------------------------- /ui-mockups/assets/fonts/ionicons.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ui-mockups/assets/fonts/ionicons.ttf -------------------------------------------------------------------------------- /ui-mockups/assets/fonts/ionicons.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ui-mockups/assets/fonts/ionicons.woff -------------------------------------------------------------------------------- /ui-mockups/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | ui-mockups 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 29 | 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /ui-mockups/login.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | ui-mockups 8 | 9 | 10 | 11 | 12 | 13 | 14 | 26 | 27 | 28 | 29 | 30 | -------------------------------------------------------------------------------- /ui-mockups/ui-mockups.bsdesign: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vacationlabs/haskell-webapps/7cbc95646693e105798b7bc0ce64602ef91be196/ui-mockups/ui-mockups.bsdesign --------------------------------------------------------------------------------