├── .env-example ├── .gitignore ├── LICENSE ├── README.md ├── package.json ├── packages.dhall ├── spago.dhall ├── src ├── WebRow.purs └── WebRow │ ├── Applets │ ├── Auth.purs │ ├── Auth │ │ ├── Effects.purs │ │ ├── Forms.purs │ │ ├── Interpret.purs │ │ ├── Interpret │ │ │ └── Dummy.purs │ │ ├── Messages.purs │ │ ├── Responses.purs │ │ ├── Routes.purs │ │ ├── Testing │ │ │ ├── Messages.purs │ │ │ └── Templates.purs │ │ └── Types.purs │ ├── Registration.purs │ └── Registration │ │ ├── Effects.purs │ │ ├── Forms.purs │ │ ├── Messages.purs │ │ ├── Responses.purs │ │ ├── Routes.purs │ │ ├── Testing │ │ ├── Messages.purs │ │ └── Templates.purs │ │ └── Types.purs │ ├── Cache.purs │ ├── Cache │ ├── Effect.purs │ ├── Interpret.purs │ └── Interpret │ │ ├── InCookies.purs │ │ └── InMemory.purs │ ├── Contrib │ ├── Data │ │ ├── JSDate.purs │ │ └── Variant.purs │ ├── Foreign │ │ └── Object │ │ │ └── Builder.purs │ ├── JSURI.purs │ ├── Routing │ │ └── Duplex.purs │ ├── Run.purs │ └── Run │ │ └── Reader.purs │ ├── Crypto.purs │ ├── Crypto │ ├── Jwt.purs │ ├── Jwt │ │ ├── Node.purs │ │ └── Node │ │ │ └── String.purs │ └── Types.purs │ ├── Devel │ └── Server │ │ └── Static.purs │ ├── Forms.purs │ ├── Forms │ ├── Bi.purs │ ├── Bi │ │ ├── Builder.purs │ │ └── Form.purs │ ├── BuilderM.purs │ ├── Builders │ │ └── Plain.purs │ ├── Layout.purs │ ├── Payload.purs │ ├── Uni.purs │ ├── Uni │ │ ├── Builder.purs │ │ └── Form.purs │ ├── Validators.purs │ ├── Validators │ │ └── Duals.purs │ ├── Widget.purs │ ├── Widgets.purs │ └── Widgets │ │ └── TextInput.purs │ ├── HTTP.purs │ ├── HTTP │ ├── Cookies.purs │ ├── Cookies │ │ ├── CookieStore.purs │ │ ├── Headers.purs │ │ └── Types.purs │ ├── MediaTypes.purs │ ├── Request.purs │ ├── Request │ │ ├── Headers.purs │ │ └── Request.purs │ ├── Response.purs │ ├── Response │ │ ├── BodyWriter.purs │ │ ├── Except.purs │ │ ├── Headers.purs │ │ └── Types.purs │ └── Types.purs │ ├── I18N.purs │ ├── I18N │ ├── ISO639 │ │ └── TwoLetter.purs │ └── Routing.purs │ ├── Logger.purs │ ├── Logger │ └── Level.purs │ ├── Mailer.purs │ ├── Message.purs │ ├── PostgreSQL.purs │ ├── PostgreSQL │ ├── CLI.purs │ ├── Internal.purs │ ├── PG.purs │ ├── Selda.purs │ └── Types.purs │ ├── Resource.purs │ ├── Routing.purs │ ├── Routing │ ├── Root.purs │ └── Types.purs │ ├── Session.purs │ ├── Session │ ├── SessionStore.purs │ └── SessionStore │ │ └── InMemory.purs │ ├── Testing.purs │ ├── Testing │ ├── Assertions.purs │ ├── HTTP.purs │ ├── HTTP │ │ ├── Cookies.purs │ │ ├── Response.purs │ │ └── Types.purs │ ├── Interpret.purs │ ├── Messages.purs │ ├── Session.purs │ └── Templates.purs │ ├── Types.purs │ └── UUID.purs └── test ├── Main.purs └── WebRow ├── Applets.purs ├── Applets ├── Auth.purs └── Registration.purs ├── HTTP.purs ├── I18N.purs ├── PostgreSQL ├── Config.purs ├── PG.purs └── Selda.purs └── Session.purs /.env-example: -------------------------------------------------------------------------------- 1 | PG_DB="purspg" 2 | PG_PORT=7781 3 | PG_IDLE_TIMEOUT_MILLISECONDS=10000 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bower_components/ 2 | /node_modules/ 3 | /.pulp-cache/ 4 | /output/ 5 | /generated-docs/ 6 | /.psc-package/ 7 | /.psc* 8 | /.purs* 9 | /.psa* 10 | /.spago 11 | package-lock.json 12 | .env 13 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | BSD 3-Clause License 2 | 3 | Copyright (c) 2020, Tomasz Rybarczyk (aka paluh) 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | 1. Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | 2. Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | 3. Neither the name of the copyright holder nor the names of its 17 | contributors may be used to endorse or promote products derived from 18 | this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" 21 | AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 22 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 23 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 24 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 25 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 26 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 27 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 28 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # purescript-webrow 2 | 3 | Let's build a highly opinionated but fully-featured web framework in PureScript. For the backend. And the frontend. 4 | 5 | WIP! 6 | 7 | 8 | 44 | -------------------------------------------------------------------------------- /package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "audiocarrier", 3 | "version": "1.0.0", 4 | "description": "", 5 | "main": "index.js", 6 | "directories": { 7 | "test": "test" 8 | }, 9 | "scripts": { 10 | "test": "echo \"Error: no test specified\" && exit 1" 11 | }, 12 | "repository": { 13 | "type": "git", 14 | "url": "git+https://github.com/paluh/audiocarrier.git" 15 | }, 16 | "author": "", 17 | "license": "ISC", 18 | "bugs": { 19 | "url": "https://github.com/paluh/audiocarrier/issues" 20 | }, 21 | "homepage": "https://github.com/paluh/audiocarrier#readme", 22 | "dependencies": { 23 | "decimal.js": "^10.2.1", 24 | "pg": "^8.4.1", 25 | "uuid": "^3.4.0", 26 | "uuid-validate": "0.0.3" 27 | } 28 | } 29 | -------------------------------------------------------------------------------- /packages.dhall: -------------------------------------------------------------------------------- 1 | let upstream = 2 | https://github.com/purescript/package-sets/releases/download/psc-0.14.4-20211030/packages.dhall sha256:5cd7c5696feea3d3f84505d311348b9e90a76c4ce3684930a0ff29606d2d816c 3 | 4 | let mkPackage = 5 | https://raw.githubusercontent.com/purescript/package-sets/psc-0.13.0-20190626/src/mkPackage.dhall sha256:0b197efa1d397ace6eb46b243ff2d73a3da5638d8d0ac8473e8e4a8fc528cf57 6 | 7 | let homogeneous = mkPackage 8 | [ "assert", "console", "effect", "foreign-object", "psci-support" 9 | , "record-extra", "typelevel-eval", "variant" 10 | ] 11 | "https://github.com/paluh/purescript-homogeneous.git" 12 | "v0.3.0" 13 | 14 | let js-uri = mkPackage 15 | [ "assert", "effect", "functions", "maybe", "prelude" ] 16 | "https://github.com/srghma/purescript-js-uri.git" 17 | "d25d83390ba9cf948f46695b55a5511895b0068c" 18 | 19 | let polyform = mkPackage 20 | [ "newtype", "ordered-collections", "variant", "profunctor", "invariant", "foreign-object" 21 | , "record", "run", "transformers", "generics-rep", "validation", "foreign" 22 | ] 23 | "https://github.com/paluh/purescript-polyform.git" 24 | "master" 25 | 26 | let polyform-batteries-core = mkPackage 27 | [ "polyform", "argonaut", "prelude", "affjax", "numbers" ] 28 | "https://github.com/purescript-polyform/batteries-core.git" 29 | "master" 30 | 31 | let polyform-batteries-env = mkPackage 32 | [ "polyform-batteries-core" , "argonaut" , "prelude" , "affjax" , "numbers" ] 33 | "https://github.com/purescript-polyform/batteries-env.git" 34 | "master" 35 | 36 | let polyform-batteries-urlencoded = mkPackage 37 | [ "polyform-batteries-core", "argonaut", "prelude", "affjax", "numbers" ] 38 | "https://github.com/purescript-polyform/batteries-urlencoded.git" 39 | "v0.1.0" 40 | 41 | let postgresql-client = mkPackage 42 | [ "aff", "arrays", "bifunctors", "bytestrings", "datetime", "decimals", "effect" 43 | , "either", "exceptions", "foldable-traversable", "foreign", "foreign-generic" 44 | , "foreign-object", "js-date", "lists", "maybe", "newtype", "nullable", "prelude" 45 | , "string-parsers", "transformers", "tuples" 46 | ] 47 | "https://github.com/rightfold/purescript-postgresql-client.git" 48 | "v4.0.0-pre" 49 | 50 | 51 | let prettyprinter = mkPackage 52 | [ "prelude", "unfoldable", "random", "ansi", "console" ] 53 | "https://github.com/Kamirus/purescript-prettyprinter.git" 54 | "master" 55 | 56 | let resourcet = mkPackage 57 | [ "aff", "ordered-collections", "refs", "transformers" ] 58 | "https://github.com/robertdp/purescript-resourcet.git" 59 | "2183bac0f1a528a5d6cdddb4fa223c4a8b9bb604" 60 | 61 | let routing-duplex-variant = mkPackage 62 | [ "routing-duplex" ] 63 | "https://github.com/paluh/purescript-routing-duplex-variant.git" 64 | "v0.1.0" 65 | 66 | let run-streaming = mkPackage 67 | [ "prelude", "run" ] 68 | "https://github.com/paluh/purescript-run-streaming.git" 69 | "master" 70 | 71 | let selda = mkPackage 72 | [ "console", "exists", "heterogeneous", "lists", "node-sqlite3", "postgresql-client" 73 | , "prelude", "simple-json", "strings", "test-unit", "transformers", "variant", "prettyprinter" 74 | ] 75 | "https://github.com/paluh/purescript-selda.git" 76 | "postgresql-client-v4.0.0" 77 | 78 | let typelevel-eval = mkPackage 79 | [ "prelude", "typelevel-prelude", "tuples", "unsafe-coerce", "leibniz" ] 80 | "https://github.com/natefaubion/purescript-typelevel-eval.git" 81 | "polykinds" 82 | 83 | -- { dependencies = 84 | -- [ "effect" 85 | -- , "foreign" 86 | -- , "prelude" 87 | -- , "typelevel-prelude" 88 | -- , "unsafe-coerce" 89 | -- ] 90 | -- , repo = 91 | -- "https://github.com/paluh/purescript-undefined-is-not-a-problem.git" 92 | -- , version = 93 | -- "master" 94 | -- } 95 | 96 | in upstream 97 | with 98 | httpure = upstream.httpure // { version = "6ce52417f79c95c9fac413189825f35472c8f937" } 99 | with 100 | homogeneous = homogeneous 101 | with 102 | js-unsafe-stringify = ../purescript-js-unsafe-stringify/spago.dhall as Location 103 | with 104 | js-uri = js-uri 105 | with 106 | logging-journald = ../purescript-logging-journald/spago.dhall as Location 107 | with 108 | media-types = upstream.media-types // { version = "4c685071074065506403197b7a5f22eb661ff17c" } 109 | with 110 | polyform = ../polyform/spago.dhall as Location 111 | with 112 | polyform-batteries-core = ../batteries-core/spago.dhall as Location 113 | with 114 | polyform-batteries-env = ../batteries-env/spago.dhall as Location 115 | with 116 | polyform-batteries-json = ../batteries-json/spago.dhall as Location 117 | with 118 | polyform-batteries-urlencoded = ../batteries-urlencoded/spago.dhall as Location 119 | with 120 | postgresql-client = ../postgresql-client/spago.dhall as Location 121 | with 122 | prettyprinter = prettyprinter 123 | with 124 | resourcet = resourcet 125 | with 126 | routing-duplex-variant = routing-duplex-variant 127 | with 128 | run-streaming = run-streaming 129 | with 130 | typelevel-eval = typelevel-eval 131 | with 132 | selda = ../selda/spago.dhall as Location 133 | with 134 | smolder = mkPackage 135 | [ "bifunctors" 136 | , "catenable-lists" 137 | , "free" 138 | , "js-uri" 139 | , "ordered-collections" 140 | , "prelude" 141 | , "strings" 142 | , "test-unit" 143 | , "transformers" 144 | , "tuples" 145 | ] 146 | "https://github.com/nsaunders/purescript-smolder.git" 147 | "ps-0.14" 148 | -------------------------------------------------------------------------------- /spago.dhall: -------------------------------------------------------------------------------- 1 | {- 2 | Welcome to a Spago project! 3 | You can edit this file as you like. 4 | -} 5 | { name = "audiocarrier" 6 | , dependencies = 7 | [ "aff" 8 | , "argonaut" 9 | , "arrays" 10 | , "b64" 11 | , "bifunctors" 12 | , "console" 13 | , "control" 14 | , "datetime" 15 | , "dotenv" 16 | , "effect" 17 | , "either" 18 | , "exceptions" 19 | , "foldable-traversable" 20 | , "foreign" 21 | , "foreign-object" 22 | , "httpure" 23 | , "identity" 24 | , "invariant" 25 | , "js-date" 26 | , "js-unsafe-stringify" 27 | , "js-uri" 28 | , "lazy" 29 | , "lists" 30 | , "maybe" 31 | , "media-types" 32 | , "newtype" 33 | , "node-buffer" 34 | , "node-fs-aff" 35 | , "node-http" 36 | , "node-process" 37 | , "node-streams" 38 | , "optparse" 39 | , "ordered-collections" 40 | , "partial" 41 | , "polyform" 42 | , "polyform-batteries-core" 43 | , "polyform-batteries-env" 44 | , "polyform-batteries-json" 45 | , "polyform-batteries-urlencoded" 46 | , "postgresql-client" 47 | , "prelude" 48 | , "profunctor" 49 | , "profunctor-lenses" 50 | , "psci-support" 51 | , "random" 52 | , "record" 53 | , "refs" 54 | , "resourcet" 55 | , "routing-duplex" 56 | , "routing-duplex-variant" 57 | , "run" 58 | , "run-streaming" 59 | , "selda" 60 | , "simple-jwt" 61 | , "smolder" 62 | , "spec" 63 | , "strings" 64 | , "transformers" 65 | , "tuples" 66 | , "typelevel-prelude" 67 | , "undefined-is-not-a-problem" 68 | , "unsafe-coerce" 69 | , "uuid" 70 | , "validation" 71 | , "variant" 72 | ] 73 | , packages = ./packages.dhall 74 | , sources = [ "src/**/*.purs", "test/**/*.purs" ] 75 | } 76 | -------------------------------------------------------------------------------- /src/WebRow.purs: -------------------------------------------------------------------------------- 1 | module WebRow 2 | ( module HTTP.Response 3 | , module HTTP.Request 4 | -- , module HTTP.Except 5 | ) where 6 | 7 | import WebRow.HTTP.Response (ok) as HTTP.Response 8 | import WebRow.HTTP.Request (body, fullPath, method) as HTTP.Request 9 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Auth.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Auth 2 | ( module Exports 3 | , localRouter 4 | , router 5 | , withUserRequired 6 | ) where 7 | 8 | import Prelude 9 | 10 | import Data.Maybe (Maybe(..)) 11 | import Data.Tuple (Tuple(..)) 12 | import Data.Variant (Variant, inj, on) 13 | import HTTPure as HTTPure 14 | import Polyform.Batteries.UrlEncoded.Validators (MissingValue) 15 | import Run (Run) 16 | import Type.Row (type (+)) 17 | import WebRow.Applets.Auth.Effects (Auth, User) as Exports 18 | import WebRow.Applets.Auth.Effects (Auth, User, AUTH) 19 | import WebRow.Applets.Auth.Forms (AuthPayload, loginForm) 20 | import WebRow.Applets.Auth.Messages (Messages) as Exports 21 | import WebRow.Applets.Auth.Responses (LoginResponse(..), Response(..), ResponseRow) 22 | import WebRow.Applets.Auth.Responses (LoginResponse(..), Response(..), ResponseRow) as Exports 23 | import WebRow.Applets.Auth.Routes (Route(..)) as Routes 24 | import WebRow.Applets.Auth.Routes (Route, RouteRow) 25 | import WebRow.Applets.Auth.Routes (localDuplex, routeBuilder, Route(..), RouteRow) as Exports 26 | import WebRow.Applets.Auth.Types (_auth, namespace) 27 | import WebRow.Forms.Payload (fromBody) 28 | import WebRow.Forms.Uni (default, validate) as Forms.Uni 29 | import WebRow.Forms.Validators (InvalidEmailFormat) 30 | import WebRow.HTTP (methodNotAllowed', method, redirect) 31 | import WebRow.Routing (fromRelativeUrl) 32 | import WebRow.Routing (printRoute) as Routing 33 | import WebRow.Session (delete, fetch, modify) as Session 34 | import WebRow.Session.SessionStore (TTL) 35 | import WebRow.Types (WebRow) 36 | 37 | type AuthRow messages routes session user eff 38 | = ( WebRow 39 | ( MissingValue 40 | + InvalidEmailFormat 41 | + ( authFailed ∷ AuthPayload 42 | | messages 43 | ) 44 | ) 45 | { user ∷ Maybe (User user) | session } 46 | (RouteRow + routes) 47 | + AUTH user 48 | + eff 49 | ) 50 | 51 | router :: 52 | ∀ eff messages responses routes routes' session user. 53 | TTL → 54 | ( Variant routes → 55 | Run 56 | (AuthRow messages routes' session user + eff) 57 | (Variant (ResponseRow + responses)) 58 | ) → 59 | Variant (RouteRow + routes) → 60 | Run 61 | (AuthRow messages routes' session user + eff) 62 | (Variant (ResponseRow + responses)) 63 | router ttl = on _auth (map (inj _auth) <$> localRouter ttl) 64 | 65 | localRouter ∷ 66 | ∀ eff messages routes session user. 67 | TTL → 68 | Route → 69 | Run (AuthRow messages routes session user eff) Response 70 | localRouter ttl = case _ of 71 | Routes.Login → login ttl 72 | Routes.Logout → logout 73 | 74 | login ∷ 75 | ∀ eff messages routes session user. 76 | TTL → 77 | Run (AuthRow messages routes session user + eff) Response 78 | login ttl = 79 | method 80 | >>= case _ of 81 | HTTPure.Post → do 82 | body ← fromBody 83 | Forms.Uni.validate loginForm body 84 | >>= case _ of 85 | Tuple Nothing formLayout → do 86 | pure $ LoginResponse (LoginFormValidationFailed formLayout) 87 | Tuple (Just user) formLayout → do 88 | Session.modify ttl _ { user = Just user } 89 | pure $ LoginResponse LoginSuccess 90 | HTTPure.Get → do 91 | let 92 | form = Forms.Uni.default loginForm 93 | pure $ LoginResponse (InitialEmailPassordForm form) 94 | method → methodNotAllowed' 95 | 96 | logout ∷ 97 | ∀ eff messages routes session user. 98 | Run 99 | ( AuthRow 100 | messages 101 | routes 102 | session 103 | user 104 | + eff 105 | ) 106 | Response 107 | logout = do 108 | void $ Session.delete 109 | pure $ LogoutResponse 110 | 111 | withUserRequired ∷ 112 | ∀ a eff messages routes session user. 113 | TTL → 114 | (User user → Run (AuthRow messages routes session user + eff) a) → 115 | Run (AuthRow messages routes session user + eff) a 116 | withUserRequired ttl f = 117 | Session.fetch (Just ttl) >>= _.user 118 | >>> case _ of 119 | Just user → f user 120 | Nothing → do 121 | relativeUrl ← Routing.printRoute (namespace Routes.Login) 122 | redirect (fromRelativeUrl relativeUrl) 123 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Auth/Effects.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Auth.Effects where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe) 6 | import Run (Run) 7 | import Run (lift) as Run 8 | import Type.Row (type (+)) 9 | import WebRow.Applets.Auth.Types (Password, _auth) 10 | import WebRow.Mailer (Email) 11 | 12 | data Auth user a 13 | = Authenticate Email Password (Maybe (User user) → a) 14 | 15 | derive instance functorAuth ∷ Functor (Auth user) 16 | 17 | type AUTH user r 18 | = ( auth ∷ Auth user | r ) 19 | 20 | type User user 21 | = { email ∷ Email | user } 22 | 23 | authenticate ∷ 24 | ∀ eff user. 25 | Email → 26 | Password → 27 | Run ( AUTH user + eff ) (Maybe (User user)) 28 | authenticate email password = Run.lift _auth (Authenticate email password identity) 29 | 30 | -- data Auth user a 31 | -- = CurrentUser (Maybe (User user) → a) 32 | -- | CheckPassword Email Password (Boolean → a) 33 | -- 34 | -- derive instance functorAuth ∷ Functor (Auth user) 35 | -- 36 | -- type AUTH user = Proxy (Auth user) 37 | -- 38 | -- currentUser ∷ ∀ eff user. Run ( auth ∷ AUTH user | eff ) (Maybe (User user)) 39 | -- currentUser = Run.lift _auth (CurrentUser identity) 40 | -- 41 | -- checkPassword ∷ ∀ eff user. Email → Password → Run ( auth ∷ AUTH user | eff ) Boolean 42 | -- checkPassword email password = Run.lift _auth (CheckPassword email password identity) 43 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Auth/Forms.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Auth.Forms where 2 | 3 | import Prelude 4 | 5 | import Data.Either (note) 6 | import Data.Validation.Semigroup (V(..)) 7 | import Polyform.Batteries (Msg, error) as Batteries 8 | import Polyform.Batteries.UrlEncoded.Validators (MissingValue) 9 | import Polyform.Validator (liftFnMV) as Validator 10 | import Run (Run) 11 | import Type.Prelude (Proxy(..)) 12 | import Type.Row (type (+)) 13 | import WebRow.Applets.Auth.Effects (authenticate) as Effects 14 | import WebRow.Applets.Auth.Effects (User, AUTH) 15 | import WebRow.Applets.Auth.Types (Password(..)) 16 | import WebRow.Forms (Uni, Layout) as Forms 17 | import WebRow.Forms.Uni (Builder, build, emailInputBuilder, passwordInputBuilder, sectionValidator) as Uni 18 | import WebRow.Forms.Validators (InvalidEmailFormat) 19 | import WebRow.Forms.Widgets (TextInput) 20 | import WebRow.Mailer (Email) 21 | 22 | _authFailed = Proxy ∷ Proxy "authFailed" 23 | 24 | type Msg = Batteries.Msg (AuthFailed + MissingValue + InvalidEmailFormat + ()) 25 | 26 | type Widgets 27 | = (TextInput () + ()) 28 | 29 | type LoginLayout 30 | = Forms.Layout Msg Widgets 31 | 32 | type AuthPayload 33 | = { email ∷ Email, password ∷ Password } 34 | 35 | type AuthFailed r 36 | = ( authFailed ∷ AuthPayload | r ) 37 | 38 | loginForm :: 39 | forall eff user. 40 | Forms.Uni 41 | (Run (AUTH user + eff)) 42 | Msg 43 | (TextInput () + ()) 44 | (User user) 45 | loginForm = 46 | Uni.build 47 | $ autheticateBuilder 48 | <<< ({ email: _, password: _ } <$> emailFormBuilder <*> passwordFormBuilder) 49 | where 50 | autheticateBuilder ∷ 51 | ∀ widgets'. 52 | Uni.Builder 53 | (Run (AUTH user + eff)) 54 | Msg 55 | -- (AuthFailed + errs') 56 | widgets' 57 | AuthPayload 58 | (User user) 59 | autheticateBuilder = 60 | Uni.sectionValidator 61 | $ Validator.liftFnMV \r → ado 62 | res ← Effects.authenticate r.email r.password 63 | in V (note (Batteries.error _authFailed (const $ "Authentication failed") r) res) 64 | 65 | passwordFormBuilder = 66 | Password 67 | <$> Uni.passwordInputBuilder 68 | { name: "password", policy: identity } 69 | 70 | emailFormBuilder = Uni.emailInputBuilder { name: "email" } 71 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Auth/Interpret.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Auth.Interpret where 2 | 3 | import WebRow.Applets.Auth.Effects (User) as Effects 4 | 5 | type User 6 | = Effects.User () 7 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Auth/Interpret/Dummy.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Auth.Interpret.Dummy where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe(..)) 6 | import Run (EFFECT, Run) 7 | import Run (interpret, on, send) as Run 8 | import Type.Row (type (+)) 9 | import WebRow.Applets.Auth.Effects (AUTH, Auth(..)) 10 | import WebRow.Applets.Auth.Types (_auth) 11 | 12 | interpret ∷ 13 | ∀ eff. 14 | Run 15 | ( EFFECT 16 | + AUTH () 17 | + eff 18 | ) 19 | ~> Run ( EFFECT + eff ) 20 | interpret = Run.interpret (Run.on _auth handler Run.send) 21 | 22 | handler ∷ 23 | ∀ eff. 24 | Auth () ~> Run ( EFFECT + eff ) 25 | handler (Authenticate email _ next) = do 26 | pure $ next (Just { email }) 27 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Auth/Messages.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Auth.Messages where 2 | 3 | import Type.Row (type (+)) 4 | import WebRow.Applets.Auth.Forms (AuthFailed) 5 | 6 | type Messages r 7 | = AuthFailed + r 8 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Auth/Responses.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Auth.Responses where 2 | 3 | import WebRow.Applets.Auth.Forms (LoginLayout) as Forms 4 | import WebRow.Applets.Auth.Types (Namespace) 5 | 6 | data LoginResponse 7 | = LoginFormValidationFailed Forms.LoginLayout 8 | | EmailPasswordMismatch Forms.LoginLayout 9 | | InitialEmailPassordForm Forms.LoginLayout 10 | | LoginSuccess 11 | 12 | data Response 13 | = LoginResponse LoginResponse 14 | | LogoutResponse 15 | 16 | type ResponseRow responses 17 | = Namespace Response responses 18 | 19 | -- response 20 | -- ∷ ∀ a eff res widgets 21 | -- . Response widgets 22 | -- → Run (response ∷ RESPONSE ( auth ∷ Response widgets | res ) | eff) a 23 | -- response = Response.response <<< namespace 24 | -- 25 | -- type LayoutResponse widgets 26 | -- = ∀ res eff a widgets 27 | -- . (Forms.Layout widgets) 28 | -- → Run (response ∷ RESPONSE ( auth ∷ (Response widgets) | res ) | eff) a 29 | -- loginFormValidationFailed ∷ forall widgets. Response widgets 30 | -- loginFormValidationFailed = LoginResponse <<< LoginFormValidationFailed 31 | -- 32 | -- emailPasswordMismatch ∷ forall widgets. Response widgets 33 | -- emailPasswordMismatch = LoginResponse <<< EmailPasswordMismatch 34 | -- 35 | -- initialEmailPassordForm ∷ forall widgets. Response widgets 36 | -- initialEmailPassordForm = response <<< LoginResponse <<< InitialEmailPassordForm 37 | -- 38 | -- loginSuccess 39 | -- ∷ ∀ res eff a widgets 40 | -- . Run (response ∷ RESPONSE ( auth ∷ Response widgets | res ) | eff) a 41 | -- loginSuccess = response $ LoginResponse LoginSuccess 42 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Auth/Routes.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Auth.Routes where 2 | 3 | import Prelude hiding ((/)) 4 | import Data.Generic.Rep (class Generic) 5 | import Prim.Row (class Lacks) as Row 6 | import Record.Builder (Builder, insert) as Record.Builder 7 | import Routing.Duplex (RouteDuplex') 8 | import Routing.Duplex.Generic as DG 9 | import Routing.Duplex.Generic.Syntax ((/)) 10 | import Type.Prelude (SProxy(..)) 11 | import WebRow.Applets.Auth.Types (Namespace) 12 | 13 | data Route 14 | = Login 15 | | Logout 16 | 17 | -- | PasswordChange 18 | -- (Maybe 19 | -- { oldPassword ∷ Password 20 | -- , password1 ∷ Password 21 | -- , password2 ∷ Password 22 | -- }) 23 | derive instance genericRoute ∷ Generic Route _ 24 | 25 | -- | ( auth ∷ Route | routes) 26 | type RouteRow routes 27 | = Namespace Route routes 28 | 29 | localDuplex ∷ RouteDuplex' Route 30 | localDuplex = 31 | DG.sum 32 | { "Login": "login" / DG.noArgs 33 | , "Logout": "logout" / DG.noArgs 34 | } 35 | 36 | routeBuilder ∷ 37 | ∀ routes. 38 | Row.Lacks "auth" routes ⇒ 39 | Record.Builder.Builder { | routes } { auth ∷ RouteDuplex' Route | routes } 40 | routeBuilder = Record.Builder.insert (SProxy ∷ SProxy "auth") localDuplex 41 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Auth/Testing/Messages.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Auth.Testing.Messages where 2 | 3 | import Prelude 4 | import Prim.Row (class Nub, class Union) as Row 5 | import Record.Builder (Builder, merge) as Record.Builder 6 | import WebRow.Applets.Auth.Forms (AuthPayload) 7 | 8 | -- type Printers 9 | -- = ( authFailed ∷ AuthPayload → String ) 10 | -- 11 | -- printers ∷ { | Printers } 12 | -- printers = 13 | -- { authFailed: 14 | -- \_ → 15 | -- ( "Email or password is incorrect. Please try again or" 16 | -- <> " use password reset option." 17 | -- ) 18 | -- } 19 | -- 20 | -- auth ∷ 21 | -- ∀ r r' r''. 22 | -- Row.Union r Printers r' ⇒ 23 | -- Row.Nub r' r'' ⇒ 24 | -- Record.Builder.Builder { | r } { | r'' } 25 | -- auth = Record.Builder.merge printers 26 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Auth/Testing/Templates.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Auth.Testing.Templates where 2 | 3 | import Prelude 4 | import Data.Variant (inj) 5 | import Run (Run) 6 | import Text.Smolder.Markup (text) as M 7 | import Type.Row (type (+)) 8 | import WebRow.Applets.Auth (Route(..)) 9 | import WebRow.Applets.Auth.Responses (LoginResponse(..), Response(..)) as Auth.Responses 10 | import WebRow.Applets.Auth.Responses (Response) as Auth 11 | import WebRow.Applets.Auth.Routes (Route) as Auth.Routes 12 | import WebRow.Applets.Auth.Types (_auth) 13 | import WebRow.HTTP (HTTPResponse) 14 | import WebRow.HTTP.Response (found, ok) 15 | import WebRow.Routing (ROUTING', fromRelativeUrl, printRoute) 16 | import WebRow.Testing.Templates (form', html) 17 | 18 | render :: forall routes t7. Auth.Response -> Run (ROUTING' ( auth ∷ Auth.Routes.Route | routes ) + t7) HTTPResponse 19 | render = case _ of 20 | Auth.Responses.LoginResponse loginResponse → case loginResponse of 21 | Auth.Responses.LoginFormValidationFailed formLayout → ok $ html $ form' formLayout 22 | Auth.Responses.EmailPasswordMismatch formLayout → ok $ html $ form' formLayout 23 | Auth.Responses.InitialEmailPassordForm formLayout → ok $ html $ form' formLayout 24 | Auth.Responses.LoginSuccess → ok $ html $ M.text "TEST" 25 | Auth.Responses.LogoutResponse → do 26 | redirectTo ← fromRelativeUrl <$> printRoute (inj _auth Login) 27 | found redirectTo 28 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Auth/Types.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Auth.Types where 2 | 3 | import Prelude 4 | import Data.Newtype (class Newtype) 5 | import Data.Variant (Variant, inj) 6 | import Type.Prelude (SProxy(..)) 7 | 8 | _auth = SProxy ∷ SProxy "auth" 9 | 10 | type Namespace t r 11 | = ( auth ∷ t | r ) 12 | 13 | namespace ∷ ∀ a r. a → Variant (Namespace a r) 14 | namespace = inj _auth 15 | 16 | newtype Password 17 | = Password String 18 | 19 | derive instance newtypePassword ∷ Newtype Password _ 20 | 21 | derive newtype instance eqPassword ∷ Eq Password 22 | 23 | derive newtype instance ordPassword ∷ Ord Password 24 | 25 | derive newtype instance showPassword ∷ Show Password 26 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Registration.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Registration 2 | ( module Exports 3 | , _emailVerification 4 | , confirmation 5 | , registerEmail 6 | , router 7 | ) where 8 | 9 | import Prelude 10 | 11 | import Data.Either (Either(..)) 12 | import Data.Maybe (Maybe(..)) 13 | import Data.Newtype (un) 14 | import Data.Tuple (Tuple(..)) 15 | import Data.Variant (Variant, inj, on) 16 | import HTTPure (Method(..)) as HTTPure 17 | import Polyform.Batteries.UrlEncoded.Validators (MissingValue) 18 | import Run (Run) 19 | import Type.Prelude (SProxy(..)) 20 | import Type.Row (type (+)) 21 | import WebRow.Applets.Registration.Effects (REGISTRATION, register) 22 | import WebRow.Applets.Registration.Effects (emailTaken) as Effects 23 | import WebRow.Applets.Registration.Forms (emailTakenForm, passwordForm) 24 | import WebRow.Applets.Registration.Messages (Messages) 25 | import WebRow.Applets.Registration.Messages (Messages) as Exports 26 | import WebRow.Applets.Registration.Responses (ConfirmationResponse(..), RegisterEmailResponse(..), Response(..), ResponseRow) 27 | import WebRow.Applets.Registration.Responses (ConfirmationResponse(..), RegisterEmailResponse(..), Response(..), ResponseRow) as Exports 28 | import WebRow.Applets.Registration.Routes (Route(..), printFullRoute) as Routes 29 | import WebRow.Applets.Registration.Routes (RouteRow) 30 | import WebRow.Applets.Registration.Routes (localDuplex, routeBuilder, Route(..), RouteRow) as Exports 31 | import WebRow.Applets.Registration.Types (SignedEmail(..), _registration) 32 | import WebRow.Crypto (CRYPTO) 33 | import WebRow.Crypto (sign, unsign) as Crypto 34 | import WebRow.Forms.Payload (fromBody) 35 | import WebRow.Forms.Uni (default, defaultM, validate) as Forms.Uni 36 | import WebRow.Forms.Validators (InvalidEmailFormat) 37 | import WebRow.HTTP (method, methodNotAllowed') 38 | import WebRow.Mailer (Email(..), MAILER) 39 | import WebRow.Mailer (send) as Mailer 40 | import WebRow.Routing (FullUrl) 41 | import WebRow.Types (WebRow) 42 | 43 | type AllMessages messages 44 | = Messages 45 | + InvalidEmailFormat 46 | + MissingValue 47 | + messages 48 | 49 | -- type WebRow messages session routes eff 50 | -- = ( COOKIES 51 | -- + HTTPEXCEPT 52 | -- + MESSAGE messages 53 | -- + REQUEST 54 | -- + ROUTING' routes 55 | -- + SESSION session 56 | -- + eff 57 | -- ) 58 | type RegistartionRow messages routes session mails eff 59 | = ( WebRow 60 | (AllMessages + messages) 61 | session 62 | (RouteRow + routes) 63 | ( CRYPTO 64 | + MAILER ( emailVerification ∷ FullUrl | mails ) 65 | + REGISTRATION 66 | + eff 67 | ) 68 | ) 69 | 70 | router :: 71 | ∀ eff mails messages responses routes routes' session. 72 | ( Variant routes → 73 | Run 74 | (RegistartionRow messages routes' session mails eff) 75 | (Variant (ResponseRow + responses)) 76 | ) → 77 | Variant (RouteRow + routes) → 78 | Run 79 | (RegistartionRow messages routes' session mails eff) 80 | (Variant (ResponseRow + responses)) 81 | router = on _registration (map (inj _registration) <$> localRouter) 82 | 83 | localRouter ∷ 84 | ∀ eff mails messages routes session. 85 | Routes.Route → 86 | Run (RegistartionRow messages routes session mails eff) Response 87 | localRouter = case _ of 88 | Routes.RegisterEmail → registerEmail 89 | Routes.Confirmation email → confirmation email 90 | 91 | _emailVerification = SProxy ∷ SProxy "emailVerification" 92 | 93 | registerEmail :: 94 | ∀ eff mails messages routes session. 95 | Run 96 | ( CRYPTO 97 | + MAILER ( emailVerification ∷ FullUrl | mails ) 98 | + REGISTRATION 99 | + WebRow 100 | (AllMessages messages) 101 | session 102 | (RouteRow routes) 103 | + eff 104 | ) 105 | Response 106 | registerEmail = 107 | method 108 | >>= case _ of 109 | HTTPure.Post → 110 | fromBody >>= Forms.Uni.validate emailTakenForm 111 | >>= case _ of 112 | Tuple (Just email@(Email e)) form → do 113 | signedEmail ← Crypto.sign e 114 | confirmationLink ← Routes.printFullRoute $ Routes.Confirmation (SignedEmail signedEmail) 115 | void $ Mailer.send ({ to: email, context: inj _emailVerification confirmationLink }) 116 | pure $ RegisterEmailResponse $ EmailSent email confirmationLink 117 | Tuple _ form → do 118 | pure $ RegisterEmailResponse $ EmailValidationFailed form 119 | HTTPure.Get → do 120 | let 121 | form = Forms.Uni.default emailTakenForm 122 | pure $ ConfirmationResponse $ InitialPasswordForm form 123 | method → methodNotAllowed' 124 | 125 | confirmation :: 126 | ∀ eff messages routes session. 127 | SignedEmail → 128 | Run 129 | ( CRYPTO 130 | + REGISTRATION 131 | + WebRow 132 | (AllMessages messages) 133 | session 134 | routes 135 | + eff 136 | ) 137 | Response 138 | confirmation signedEmail = do 139 | validateEmail signedEmail 140 | >>= case _ of 141 | Left err → pure err 142 | Right email → 143 | method 144 | >>= case _ of 145 | HTTPure.Post → 146 | fromBody >>= Forms.Uni.validate passwordForm 147 | >>= case _ of 148 | Tuple (Just password) _ → do 149 | register email password 150 | pure $ ConfirmationResponse $ ConfirmationSucceeded email password 151 | Tuple _ form → do 152 | pure $ ConfirmationResponse $ PasswordValidationFailed form 153 | HTTPure.Get → do 154 | form ← Forms.Uni.defaultM passwordForm 155 | pure $ ConfirmationResponse $ InitialPasswordForm form 156 | _ → methodNotAllowed' 157 | where 158 | validateEmail = 159 | un SignedEmail >>> Crypto.unsign 160 | >=> case _ of 161 | Left _ → pure $ Left (ConfirmationResponse InvalidEmailSignature) 162 | Right emailStr → do 163 | let 164 | email = Email emailStr 165 | Effects.emailTaken email 166 | >>= if _ then 167 | pure $ Left (ConfirmationResponse $ EmailRegisteredInbetween email) 168 | else 169 | pure $ Right email 170 | 171 | -- -- type ChangeEmailPayload = { current ∷ String, new ∷ String } 172 | -- -- 173 | -- -- changeEmail 174 | -- -- ∷ ∀ a eff ctx res routes user 175 | -- -- . Run 176 | -- -- (Effects ctx res routes user eff) 177 | -- -- a 178 | -- -- changeEmail = do 179 | -- -- { email: current@(Email c) } ← userRequired 180 | -- -- request >>= _.method >>> case _ of 181 | -- -- HTTPure.Post → fromBody >>= Forms.Dual.run (updateEmailForm current) >>= case _ of 182 | -- -- Tuple form (Just email@(Email e)) → do 183 | -- -- signedPayload ← sign $ writeJSON { current: c, new: e } 184 | -- -- fullUrl@(FullUrl url) ← Routes.printFullRoute $ Routes.ChangeEmailConfirmation { payload: signedPayload } 185 | -- -- void $ sendMail { to: email, text: "Verification link for email change" <> url, subject: "Email verification" } 186 | -- -- -- | TODO: Fix response 187 | -- -- response $ Responses.RegisterEmailResponse $ Responses.EmailSent email fullUrl 188 | -- -- Tuple form _ → do 189 | -- -- -- | TODO: Fix response 190 | -- -- response $ Responses.RegisterEmailResponse $ Responses.EmailValidationFailed form 191 | -- -- HTTPure.Get → do 192 | -- -- form ← Forms.Dual.build (updateEmailForm current) current 193 | -- -- response $ Responses.ChangeEmailResponse $ Responses.ChangeEmailInitialForm form 194 | -- -- method → methodNotAllowed' 195 | -- -- 196 | -- -- changeEmailConfirmation 197 | -- -- ∷ ∀ a eff ctx res routes user 198 | -- -- . { payload ∷ String } 199 | -- -- → Run 200 | -- -- (Effects ctx res routes user eff) 201 | -- -- a 202 | -- -- changeEmailConfirmation { payload } = do 203 | -- -- (p@{ current: currentEmail, new: newEmail } ∷ ChangeEmailPayload) ← 204 | -- -- maybe (badRequest' "Bad signature") pure 205 | -- -- <<< ((hush <<< readJSON) <=< hush) 206 | -- -- <=< unsign 207 | -- -- $ payload 208 | -- -- Effects.emailTaken (Email newEmail) >>= flip when do 209 | -- -- response $ Responses.ConfirmationResponse $ Responses.EmailRegisteredInbetween (Email newEmail) 210 | -- -- 211 | -- -- badRequest' $ "CORRECTLY PARSED PAYLOAD: " <> writeJSON p 212 | -- -- 213 | -- -- -- request >>= _.method >>> case _ of 214 | -- -- -- HTTPure.Post → fromBody >>= Forms.Dual.run updateEmailForm >>= case _ of 215 | -- -- -- Tuple form (Just email@(Email e)) → do 216 | -- -- -- signedPayload ← sign $ writeJSON { current: c, new: e } 217 | -- -- -- fullUrl@(FullUrl url) ← Routes.printFullRoute $ Routes.ChangeEmailConfirmation { payload: signedPayload } 218 | -- -- -- void $ sendMail { to: email, text: "Verification link for email change" <> url, subject: "Email verification" } 219 | -- -- -- response $ Responses.RegisterEmailResponse $ Responses.EmailSent email fullUrl 220 | -- -- -- Tuple form _ → do 221 | -- -- -- response $ Responses.RegisterEmailResponse $ Responses.EmailValidationFailed form 222 | -- -- -- HTTPure.Get → do 223 | -- -- -- let 224 | -- -- -- form = Forms.Dual.build updateEmailForm current 225 | -- -- -- response $ Responses.ChangeEmailResponse $ Responses.ChangeEmailInitialForm form 226 | -- -- -- method → methodNotAllowed' 227 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Registration/Effects.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Registration.Effects where 2 | 3 | import Prelude 4 | 5 | import Run (Run) 6 | import Run (lift) as Run 7 | import Type.Prelude (SProxy(..)) 8 | import Type.Row (type (+)) 9 | import WebRow.Applets.Auth.Types (Password) 10 | import WebRow.Mailer (Email) 11 | 12 | data Registration a 13 | = EmailTakenF Email (Boolean → a) 14 | | RegisterF Email Password a 15 | 16 | derive instance functorRegistration ∷ Functor Registration 17 | 18 | _registration = SProxy ∷ SProxy "registration" 19 | 20 | type REGISTRATION r 21 | = ( registration ∷ Registration | r ) 22 | 23 | emailTaken ∷ ∀ eff. Email → Run ( REGISTRATION + eff ) Boolean 24 | emailTaken email = do 25 | Run.lift _registration (EmailTakenF email identity) 26 | 27 | register ∷ ∀ eff. Email → Password → Run ( REGISTRATION + eff ) Unit 28 | register email password = do 29 | Run.lift _registration (RegisterF email password unit) 30 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Registration/Forms.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Registration.Forms where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe(..)) 6 | import Data.Newtype (un) 7 | import Data.String (Pattern(..), contains) as String 8 | import Data.Validation.Semigroup (invalid) 9 | import Data.Variant (Variant) 10 | import Polyform.Batteries (Msg, error) as Batteries 11 | import Polyform.Batteries.UrlEncoded.Validators (MissingValue) 12 | import Polyform.Validator (check, checkM, liftFn, liftFnV) as Validator 13 | import Polyform.Validator.Dual (check) as Validator.Dual 14 | import Type.Prelude (Proxy(..)) 15 | import Type.Row (type (+)) 16 | import WebRow.Applets.Auth.Types (Password(..)) 17 | import WebRow.Applets.Registration.Effects (emailTaken) as Effects 18 | import WebRow.Forms.Layout (Layout) as Forms 19 | import WebRow.Forms.Uni (build) as Uni 20 | import WebRow.Forms.Uni (build, emailInputBuilder, passwordInputBuilder, sectionValidator, textInputBuilder) as Forms.Uni 21 | import WebRow.Forms.Validators (InvalidEmailFormat) 22 | import WebRow.Forms.Widgets (TextInput) 23 | import WebRow.Mailer (Email(..)) 24 | 25 | type Msg = Batteries.Msg (MissingValue + InvalidEmailFormat + PasswordsMismatch + EmailTaken + ()) 26 | 27 | type Widgets 28 | = (TextInput () + ()) 29 | 30 | type FormLayout 31 | = Forms.Layout Msg Widgets 32 | 33 | _emailTaken = Proxy ∷ Proxy "emailTaken" 34 | 35 | type EmailTaken r 36 | = ( emailTaken ∷ Email | r ) 37 | 38 | emailTakenForm = Uni.build $ Forms.Uni.emailInputBuilder { name: "email", policy: validator } 39 | where 40 | validator = 41 | Validator.checkM 42 | (Batteries.error _emailTaken (const "Given email is already taken")) 43 | (map not <$> Effects.emailTaken) 44 | 45 | _passwordsMismatch = Proxy ∷ Proxy "passwordsMismatch" 46 | 47 | type PasswordsInput 48 | = { password1 ∷ String, password2 ∷ String } 49 | 50 | type PasswordsMismatch r 51 | = ( passwordsMismatch ∷ PasswordsInput | r ) 52 | 53 | passwordForm = Forms.Uni.build $ Forms.Uni.sectionValidator validator <<< passwordsForm 54 | where 55 | validator = 56 | Validator.liftFn (Password <<< _.password1) 57 | <<< Validator.check 58 | (Batteries.error _passwordsMismatch (const "Given passwords don't match")) 59 | (\r → r.password1 == r.password2) 60 | 61 | passwordsForm = 62 | { password1: _, password2: _ } 63 | <$> Forms.Uni.passwordInputBuilder {} 64 | <*> Forms.Uni.passwordInputBuilder {} 65 | 66 | -- _sameEmail = Proxy ∷ Proxy "sameEmail" 67 | -- 68 | -- -- | This an example of "Forms.Dual.Form" 69 | -- -- | we are going to drop it from here 70 | -- -- | as bidirectionallity is not necessary 71 | -- -- | in this case (we don't have to fill email value) :-P 72 | -- updateEmailForm email = Forms.Dual.Form $ 73 | -- identity ~ Forms.Dual.textInput "" "email" dual 74 | -- <* (const "") ~ Auth.Forms.checkPassword email 75 | -- where 76 | -- emailDiffers = Validator.Dual.check 77 | -- (Batteries.error _sameEmail) 78 | -- (not <<< eq email) 79 | -- 80 | -- dual = UrlEncoded.Validators.Duals.singleValue >>> Fields.Duals.email >>> emailDiffers >>> Dual.dual' emailTakenValidator 81 | -- 82 | -- ======= 83 | -- import Prelude 84 | -- 85 | -- import Data.Either (Either(..)) 86 | -- import Data.String (Pattern(..), contains) as String 87 | -- import Data.Validation.Semigroup (invalid) 88 | -- import Polyform.Validator (hoistFnEither, hoistFnMV, hoistFnV) as Validator 89 | -- import Polyform.Validator (valid) 90 | -- import Polyform.Validators.UrlEncoded (string) 91 | -- import WebRow.Applets.Auth.Types (Password(..)) 92 | -- import WebRow.Applets.Registration.Effects (emailTaken) as Effects 93 | -- import WebRow.Forms.Builders.Plain (field) as Forms.Builders.Plain 94 | -- import WebRow.Forms.Builders.Plain (passwordField, sectionValidator) 95 | -- import WebRow.Mailer (Email(..)) 96 | -- 97 | -- -- | TODO: Move this to polyform validators 98 | -- nonEmptyString = string >>> Validator.hoistFnEither \p → case p of 99 | -- "" → Left ["Value is required"] 100 | -- otherwise → Right p 101 | -- 102 | -- -- | TODO: Fix this validator - possibly use this: 103 | -- -- | 104 | -- -- | https://github.com/cdepillabout/purescript-email-validate 105 | -- -- | 106 | -- -- | and push this validator to polyform-validators 107 | -- emailFormat = Validator.hoistFnV \email → 108 | -- -- | @ is just enough for as to send an email ;-) 109 | -- if String.contains (String.Pattern "@") email 110 | -- then valid (Email email) 111 | -- else invalid [ "Invalid email format: " <> email ] 112 | -- 113 | -- emailTaken = Validator.hoistFnMV \email → do 114 | -- Effects.emailTaken email >>= if _ 115 | -- then pure $ invalid [ "Email already taken:" <> show email ] 116 | -- else pure $ valid email 117 | -- 118 | -- emailForm = Forms.Builders.Plain.field { name: "email", type_: "email" } validator 119 | -- where 120 | -- validator = nonEmptyString >>> emailFormat >>> emailTaken 121 | -- 122 | -- passwordForm = passwordsForm >>> sectionValidator "no-match" validator 123 | -- where 124 | -- validator = Validator.hoistFnEither \{ password1, password2 } → if password1 /= password2 125 | -- then 126 | -- Left ["Passwords don't match"] 127 | -- else 128 | -- Right (Password password1) 129 | -- 130 | -- passwordsForm = { password1: _, password2: _ } 131 | -- <$> passwordField "password1" nonEmptyString 132 | -- <*> passwordField "password2" nonEmptyString 133 | -- >>>>>>> origin/auth-applet 134 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Registration/Messages.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Registration.Messages where 2 | 3 | import Type.Row (type (+)) 4 | import WebRow.Applets.Registration.Forms (EmailTaken, PasswordsMismatch) 5 | 6 | type Messages r 7 | = EmailTaken + PasswordsMismatch + r 8 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Registration/Responses.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Registration.Responses where 2 | 3 | import WebRow.Applets.Auth.Types (Password) 4 | import WebRow.Applets.Registration.Forms (FormLayout) 5 | import WebRow.Applets.Registration.Types (Namespace) 6 | import WebRow.Mailer (Email) 7 | import WebRow.Routing (FullUrl) 8 | 9 | data ConfirmationResponse 10 | = ConfirmationSucceeded Email Password 11 | | InvalidEmailSignature 12 | | InitialPasswordForm FormLayout 13 | | EmailRegisteredInbetween Email 14 | | PasswordValidationFailed FormLayout 15 | 16 | data RegisterEmailResponse 17 | = EmailSent Email FullUrl 18 | | EmailValidationFailed FormLayout 19 | | InitialEmailForm FormLayout 20 | 21 | data ChangeEmailResponse 22 | = ChangeEmailInitialForm FormLayout 23 | 24 | data Response 25 | = ConfirmationResponse ConfirmationResponse 26 | | RegisterEmailResponse RegisterEmailResponse 27 | | ChangeEmailResponse ChangeEmailResponse 28 | 29 | type ResponseRow responses 30 | = Namespace Response responses 31 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Registration/Routes.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Registration.Routes where 2 | 3 | import Prelude hiding ((/)) 4 | import Data.Generic.Rep (class Generic) 5 | import Data.Lens.Iso.Newtype (_Newtype) 6 | import Prim.Row (class Lacks) as Row 7 | import Record.Builder (Builder, insert) as Record.Builder 8 | import Routing.Duplex (RouteDuplex', string) 9 | import Routing.Duplex as D 10 | import Routing.Duplex.Generic (noArgs) 11 | import Routing.Duplex.Generic as DG 12 | import Routing.Duplex.Generic.Syntax ((/), (?)) 13 | import Run (Run) 14 | import Type.Row (type (+)) 15 | import WebRow.Applets.Registration.Types (Namespace, SignedEmail, _registration, namespace) 16 | import WebRow.Routing (FullUrl, ROUTING') 17 | import WebRow.Routing (printFullRoute) as Route 18 | 19 | data Route 20 | = RegisterEmail 21 | | Confirmation SignedEmail 22 | 23 | -- | ChangeEmail 24 | -- | ChangeEmailConfirmation { payload ∷ String } 25 | derive instance genericRoute ∷ Generic Route _ 26 | 27 | -- | ( registartion ∷ Route | routes) 28 | type RouteRow routes 29 | = Namespace Route routes 30 | 31 | localDuplex ∷ RouteDuplex' Route 32 | localDuplex = 33 | DG.sum 34 | { "RegisterEmail": noArgs 35 | , "Confirmation": "confirmation" / (_Newtype $ D.param "email" ∷ RouteDuplex' SignedEmail) 36 | , "ChangeEmail": "change-email" / noArgs 37 | , "ChangeEmailConfirmation": "change-email" / "confirmation" ? { payload: string } 38 | } 39 | 40 | routeBuilder ∷ 41 | ∀ routes. 42 | Row.Lacks "registration" routes ⇒ 43 | Record.Builder.Builder { | routes } { registration ∷ RouteDuplex' Route | routes } 44 | routeBuilder = Record.Builder.insert _registration localDuplex 45 | 46 | printFullRoute ∷ ∀ eff routes. Route → Run (ROUTING' (RouteRow routes) + eff) FullUrl 47 | printFullRoute = Route.printFullRoute <<< namespace 48 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Registration/Testing/Messages.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Registration.Testing.Messages where 2 | 3 | import Prelude 4 | import Prim.Row (class Nub, class Union) as Row 5 | import Record.Builder (Builder, merge) as Record.Builder 6 | import WebRow.Applets.Registration.Forms (PasswordsInput) 7 | import WebRow.Mailer (Email(..)) 8 | 9 | -- type Printers 10 | -- = ( emailTaken ∷ Email → String 11 | -- , passwordsMismatch ∷ PasswordsInput → String 12 | -- ) 13 | -- 14 | -- printers ∷ { | Printers } 15 | -- printers = 16 | -- { emailTaken: 17 | -- \(Email email) → 18 | -- ( "Accout for a given email is already registered. " 19 | -- <> " Please use password reset option if you are not able to " 20 | -- <> " access your account." 21 | -- ) 22 | -- , passwordsMismatch: 23 | -- \_ → 24 | -- "Passwords don't match. Please ensure that both provided password are equal." 25 | -- } 26 | -- 27 | -- registration ∷ 28 | -- ∀ r r' r''. 29 | -- Row.Union r Printers r' ⇒ 30 | -- Row.Nub r' r'' ⇒ 31 | -- Record.Builder.Builder { | r } { | r'' } 32 | -- registration = Record.Builder.merge printers 33 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Registration/Testing/Templates.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Registration.Testing.Templates where 2 | 3 | import Prelude 4 | import JS.Unsafe.Stringify (unsafeStringify) 5 | import Run (Run) 6 | import Text.Smolder.HTML (a, p) as M 7 | import Text.Smolder.HTML.Attributes as A 8 | import Text.Smolder.Markup (safe, (!)) 9 | import Text.Smolder.Markup (text) as M 10 | import Type.Row (type (+)) 11 | import WebRow.Applets.Auth.Routes (Route) as Auth.Routes 12 | import WebRow.Applets.Registration.Responses (ChangeEmailResponse(..), ConfirmationResponse(..), RegisterEmailResponse(..), Response(..)) 13 | import WebRow.Applets.Registration.Responses (Response) as Registration 14 | import WebRow.HTTP (HTTPResponse) 15 | import WebRow.HTTP.Response (ok) 16 | import WebRow.Routing (FullUrl(..), ROUTING') 17 | import WebRow.Testing.Templates (form', html) 18 | 19 | render :: forall routes t7. Registration.Response -> Run (ROUTING' ( auth ∷ Auth.Routes.Route | routes ) + t7) HTTPResponse 20 | render = case _ of 21 | RegisterEmailResponse r → case r of 22 | EmailValidationFailed formLayout → ok $ html $ form' formLayout 23 | EmailSent email (FullUrl url) → 24 | ok 25 | $ html do 26 | M.p 27 | $ M.text ("Email sent to " <> show email) 28 | M.p 29 | $ do 30 | M.text ("Activation link is: ") 31 | M.a ! (safe $ A.href url) $ M.text url 32 | InitialEmailForm formLayout → ok $ html $ form' formLayout 33 | ConfirmationResponse r → case r of 34 | ConfirmationSucceeded email password → 35 | ok $ html 36 | $ do 37 | M.text 38 | $ "email: " 39 | <> unsafeStringify email 40 | <> "; password: " 41 | <> unsafeStringify password 42 | EmailRegisteredInbetween _ → ok $ html $ M.text "Email registered inbetween" 43 | InitialPasswordForm formLayout → ok $ html $ form' formLayout 44 | InvalidEmailSignature → ok $ html $ M.text "InvalidEmailSignature" 45 | PasswordValidationFailed formLayout → ok $ html $ form' formLayout 46 | ChangeEmailResponse r → case r of 47 | ChangeEmailInitialForm formLayout → ok $ html $ form' formLayout 48 | -------------------------------------------------------------------------------- /src/WebRow/Applets/Registration/Types.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Applets.Registration.Types where 2 | 3 | import Prelude 4 | import Data.Newtype (class Newtype) 5 | import Data.Variant (Variant, inj) 6 | import Type.Prelude (SProxy(..)) 7 | 8 | newtype SignedEmail 9 | = SignedEmail String 10 | 11 | derive instance newtypeSignedEmail ∷ Newtype SignedEmail _ 12 | 13 | derive newtype instance showSignedEmail ∷ Show SignedEmail 14 | 15 | _registration = SProxy ∷ SProxy "registration" 16 | 17 | type Namespace t r 18 | = ( registration ∷ t | r ) 19 | 20 | namespace ∷ ∀ a r. a → Variant (Namespace a r) 21 | namespace = inj _registration 22 | -------------------------------------------------------------------------------- /src/WebRow/Cache.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Cache 2 | ( module Interpret 3 | , module Effect 4 | ) where 5 | 6 | import WebRow.Cache.Effect (deleteAt, delete, lookupAt, lookup, insertAt, insert, _cache, Key, CACHE, Cache) as Effect 7 | import WebRow.Cache.Interpret (runOnInterfaceAt, runOnInterface, Interface) as Interpret 8 | 9 | -------------------------------------------------------------------------------- /src/WebRow/Cache/Effect.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Cache.Effect where 2 | 3 | import Prelude 4 | import Data.Maybe (Maybe) 5 | 6 | import Prim.Row (class Cons) as Row 7 | import Run (Run) 8 | import Run as Run 9 | import Type.Prelude (class IsSymbol) 10 | import Type.Row (type (+)) 11 | import Type.Prelude (Proxy(..)) 12 | 13 | type Key 14 | = String 15 | 16 | data Cache attrs value a 17 | = DeleteF Key a 18 | | LookupF Key (Maybe value → a) 19 | | InsertF Key attrs value (Boolean → a) 20 | 21 | derive instance functorDataStoreF ∷ Functor (Cache attrs val) 22 | 23 | type CACHE attrs v eff 24 | = ( cache ∷ Cache attrs v | eff ) 25 | 26 | liftCacheAt ∷ 27 | ∀ a attrs eff eff_ s v. 28 | IsSymbol s ⇒ 29 | Row.Cons s (Cache attrs v) eff_ eff ⇒ 30 | Proxy s → 31 | Cache attrs v a → 32 | Run eff a 33 | liftCacheAt = Run.lift 34 | 35 | _cache = Proxy ∷ Proxy "cache" 36 | 37 | deleteAt ∷ 38 | ∀ attrs eff eff_ l v. 39 | IsSymbol l ⇒ 40 | Row.Cons l (Cache attrs v) eff_ eff ⇒ 41 | (Proxy l) → 42 | Key → 43 | Run eff Unit 44 | deleteAt l key = liftCacheAt l (DeleteF key unit) 45 | 46 | delete ∷ 47 | ∀ attrs eff v. 48 | Key → 49 | Run (CACHE attrs v + eff) Unit 50 | delete = deleteAt _cache 51 | 52 | lookupAt ∷ 53 | ∀ attrs eff eff_ l v. 54 | IsSymbol l ⇒ 55 | Row.Cons l (Cache attrs v) eff_ eff ⇒ 56 | Proxy l → 57 | Key → 58 | Run eff (Maybe v) 59 | lookupAt l key = liftCacheAt l (LookupF key identity) 60 | 61 | lookup ∷ 62 | ∀ attrs eff v. 63 | Key → 64 | Run (CACHE attrs v + eff) (Maybe v) 65 | lookup = lookupAt _cache 66 | 67 | insertAt ∷ 68 | ∀ attrs eff eff_ l v. 69 | IsSymbol l ⇒ 70 | Row.Cons l (Cache attrs v) eff_ eff ⇒ 71 | Proxy l → 72 | Key → 73 | attrs → 74 | v → 75 | Run eff Boolean 76 | insertAt l key attrs val = liftCacheAt l (InsertF key attrs val identity) 77 | 78 | insert ∷ 79 | ∀ attrs eff v. 80 | Key → 81 | attrs → 82 | v → 83 | Run (CACHE attrs v + eff) Boolean 84 | insert = insertAt _cache 85 | 86 | -------------------------------------------------------------------------------- /src/WebRow/Cache/Interpret.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Cache.Interpret where 2 | 3 | import Prelude 4 | 5 | import Data.Argonaut (Json) 6 | import Data.Argonaut (class DecodeJson, class EncodeJson, decodeJson, encodeJson, jsonParser, stringify) as Argonaut 7 | import Data.Either (hush) 8 | import Data.Maybe (Maybe) 9 | import Prim.Row (class Cons) as Row 10 | import Run (Run) 11 | import Run as Run 12 | import Type.Prelude (class IsSymbol, Proxy(..)) 13 | import Type.Row (type (+)) 14 | import WebRow.Cache.Effect (CACHE, Cache(..), Key, Cache, _cache) 15 | 16 | -- | Do we want to drop `delete` and use `put ∷ Key → Maybe a → m Boolean` 17 | type Interface m attrs a 18 | = { delete ∷ Key → m Boolean 19 | , lookup ∷ Key → m (Maybe a) 20 | , insert ∷ Key → attrs → a → m Boolean 21 | } 22 | 23 | hoist ∷ ∀ attrs m m'. (m ~> m') → Interface m attrs ~> Interface m' attrs 24 | hoist h s = { delete, insert, lookup } 25 | where 26 | delete = h <$> s.delete 27 | 28 | lookup = h <$> s.lookup 29 | 30 | insert k attrs = h <$> s.insert k attrs 31 | 32 | 33 | imapInterface ∷ 34 | ∀ a attrs b m. 35 | Monad m ⇒ 36 | { parse ∷ a → Maybe b 37 | , print ∷ b → a 38 | } → 39 | Interface m attrs a → 40 | Interface m attrs b 41 | imapInterface { parse, print } c = 42 | { delete: c.delete 43 | , lookup: c.lookup >=> (_ >>= parse) >>> pure 44 | , insert: \k attrs v → c.insert k attrs (print v) 45 | } 46 | 47 | jsonify ∷ 48 | ∀ attrs m. 49 | Monad m ⇒ 50 | Interface m attrs String → 51 | Interface m attrs Json 52 | jsonify = 53 | imapInterface 54 | { parse: Argonaut.jsonParser >>> hush 55 | , print: Argonaut.stringify 56 | } 57 | 58 | argonautify ∷ 59 | ∀ a attrs m. 60 | Monad m ⇒ 61 | Argonaut.DecodeJson a ⇒ 62 | Argonaut.EncodeJson a ⇒ 63 | Interface m attrs String → 64 | Interface m attrs a 65 | argonautify = 66 | jsonify 67 | >>> imapInterface 68 | { parse: Argonaut.decodeJson >>> hush 69 | , print: Argonaut.encodeJson 70 | } 71 | 72 | runOnInterfaceAt ∷ 73 | ∀ a attrs eff eff' l v. 74 | IsSymbol l ⇒ 75 | Row.Cons l (Cache attrs v) eff eff' ⇒ 76 | Proxy l → 77 | Interface (Run eff) attrs v → 78 | Run eff' a → Run eff a 79 | runOnInterfaceAt l interface = Run.interpret (Run.on l handleKeyValueStore Run.send) 80 | where 81 | handleKeyValueStore ∷ ∀ b. Cache attrs v b → Run eff b 82 | handleKeyValueStore = case _ of 83 | DeleteF k next → pure next 84 | LookupF k next → interface.lookup k <#> next 85 | InsertF k v attrs next → interface.insert k v attrs <#> next 86 | 87 | runOnInterface ∷ 88 | ∀ a attrs eff v. 89 | Interface (Run eff) attrs v → 90 | Run (CACHE attrs v + eff) a → 91 | Run eff a 92 | runOnInterface = runOnInterfaceAt _cache 93 | -------------------------------------------------------------------------------- /src/WebRow/Cache/Interpret/InCookies.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Cache.Interpret.InCookies where 2 | 3 | import Prelude 4 | 5 | import Data.Lazy (force) as Lazy 6 | import Run (EFFECT, Run) 7 | import Type.Row (type (+)) 8 | import WebRow.Cache.Interpret (Interface) 9 | import WebRow.Crypto (CRYPTO) 10 | import WebRow.HTTP (COOKIES) 11 | import WebRow.HTTP.Cookies (Attributes, delete, lookup, set) as Cookies 12 | 13 | type InCookies a 14 | = Interface (Run (COOKIES + CRYPTO + EFFECT + ())) Cookies.Attributes a 15 | 16 | inCookies ∷ InCookies String 17 | inCookies = 18 | let 19 | -- | TODO: Check if "value+key" < 4000 bytes 20 | insert k attrs value = Cookies.set k { attributes: attrs, value } 21 | 22 | delete key = Cookies.delete key 23 | 24 | lookup key = Lazy.force <$> (Cookies.lookup key) 25 | in 26 | { delete, insert, lookup } 27 | -------------------------------------------------------------------------------- /src/WebRow/Cache/Interpret/InMemory.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Cache.Interpret.InMemory where 2 | 3 | import Prelude 4 | import Data.Map (Map) 5 | import Data.Map (delete, empty, insert, lookup) as Map 6 | import Effect (Effect) 7 | import Effect.Ref (Ref) 8 | import Effect.Ref (modify, new, read) as Ref 9 | import WebRow.Cache.Interpret (Interface) 10 | 11 | type InMemory attrs a 12 | = Interface Effect attrs a 13 | 14 | -- | TODO: Provide also efficient JS Map reference 15 | -- | based implementation done through mutable 16 | -- | reference. 17 | new ∷ ∀ a attrs. Effect (InMemory attrs a) 18 | new = forRef <$> Ref.new Map.empty 19 | 20 | forRef ∷ ∀ a attrs. Ref (Map String a) → InMemory attrs a 21 | forRef ref = 22 | let 23 | delete k = (void $ Ref.modify (Map.delete k) ref) *> pure true 24 | 25 | lookup k = do 26 | m ← Ref.read ref 27 | pure $ Map.lookup k m 28 | 29 | insert k attrs v = do 30 | void $ Ref.modify (Map.insert k v) ref 31 | pure true 32 | in 33 | { delete, insert, lookup } 34 | -------------------------------------------------------------------------------- /src/WebRow/Contrib/Data/JSDate.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Contrib.Data.JSDate where 2 | 3 | import Data.DateTime.Instant (Instant) 4 | import Data.JSDate (JSDate, fromInstant) 5 | import Unsafe.Coerce (unsafeCoerce) 6 | 7 | epoch ∷ JSDate 8 | epoch = fromInstant (unsafeCoerce 0 ∷ Instant) 9 | -------------------------------------------------------------------------------- /src/WebRow/Contrib/Data/Variant.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Contrib.Data.Variant where 2 | 3 | import Prelude 4 | 5 | import Data.Symbol (reflectSymbol) 6 | import Data.Variant (Unvariant(..), Variant, on, unvariant) 7 | import Prim.Row (class Cons) as Row 8 | import Type.Prelude (class IsSymbol, SProxy) 9 | import Unsafe.Coerce (unsafeCoerce) 10 | 11 | tag ∷ ∀ r. Variant r → String 12 | tag v = 13 | let 14 | Unvariant f = unvariant v 15 | in 16 | f (\c _ → reflectSymbol c) 17 | 18 | override 19 | ∷ ∀ sym a b r1 r2 20 | . Row.Cons sym a r1 r2 21 | ⇒ IsSymbol sym 22 | ⇒ SProxy sym 23 | → (a → b) 24 | → (Variant r2 → b) 25 | → Variant r2 26 | → b 27 | override p f g = (g <<< expand) # on p f 28 | where 29 | expand ∷ Variant r1 → Variant r2 30 | expand = unsafeCoerce 31 | -------------------------------------------------------------------------------- /src/WebRow/Contrib/Foreign/Object/Builder.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Contrib.Foreign.Object.Builder where 2 | 3 | import Prelude 4 | import Foreign.Object (Object) 5 | import Record.Unsafe (unsafeSet) as Record.Unsafe 6 | import Unsafe.Coerce (unsafeCoerce) 7 | 8 | newtype Builder a 9 | = Builder (Object a → Object a) 10 | 11 | instance semigroupBuilder ∷ Semigroup (Builder a) where 12 | append (Builder b1) (Builder b2) = Builder (b1 <<< b2) 13 | 14 | instance monoidBuilder ∷ Monoid (Builder a) where 15 | mempty = Builder identity 16 | 17 | insert ∷ ∀ a. String → a → Builder a 18 | insert k v = unsafeCoerce (Record.Unsafe.unsafeSet k v) 19 | 20 | build ∷ ∀ a. Builder a → Object a 21 | build (Builder b) = b (unsafeCoerce {}) 22 | -------------------------------------------------------------------------------- /src/WebRow/Contrib/JSURI.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Contrib.JSURI where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (fromJust) 6 | import JSURI (decodeURIComponent, encodeURIComponent) 7 | import Partial.Unsafe (unsafePartial) 8 | 9 | unsafeDecodeURIComponent :: String -> String 10 | unsafeDecodeURIComponent s = unsafePartial $ fromJust $ decodeURIComponent s 11 | 12 | unsafeEncodeURIComponent :: String -> String 13 | unsafeEncodeURIComponent s = unsafePartial $ fromJust $ encodeURIComponent s 14 | -------------------------------------------------------------------------------- /src/WebRow/Contrib/Routing/Duplex.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Contrib.Routing.Duplex where 2 | 3 | import Prelude 4 | import Routing.Duplex (RouteDuplex(..), RouteDuplex') 5 | import Routing.Duplex.Parser (RouteParser(..), RouteResult(..)) 6 | import Routing.Duplex.Printer (RoutePrinter(..)) 7 | import Routing.Duplex.Types (RouteParams) 8 | 9 | -- | The rest of query parameters in a 10 | -- | rough format: `Array (Tuple String String)` 11 | -- | 12 | -- | Example usage - extracting rest of the query: 13 | -- | 14 | -- | route = D.path "confirmation" $ registrationPasswordQuery 15 | -- | where 16 | -- | registrationPasswordQuery = D.record 17 | -- | # (SProxy ∷ SProxy "email") := (_Newtype <<< D.string $ D.param "email") 18 | -- | # (SProxy ∷ SProxy "form") := WebRow.Routing.Duplex.params 19 | params ∷ RouteDuplex' RouteParams 20 | params = RouteDuplex printer parser 21 | where 22 | parser ∷ RouteParser RouteParams 23 | parser = Chomp $ \state → Success (state { params = [] }) state.params 24 | 25 | printer ∷ RouteParams → RoutePrinter 26 | printer p = RoutePrinter \state → state { params = p } 27 | -------------------------------------------------------------------------------- /src/WebRow/Contrib/Run.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Contrib.Run where 2 | 3 | import Run (EFFECT, AFF) 4 | import Type.Prelude (SProxy(..)) 5 | 6 | _effect = SProxy ∷ SProxy "effect" 7 | 8 | type EffRow eff = EFFECT eff 9 | 10 | _aff = SProxy ∷ SProxy "aff" 11 | 12 | type AffRow eff = AFF eff 13 | -------------------------------------------------------------------------------- /src/WebRow/Contrib/Run/Reader.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Contrib.Run.Reader where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either(..)) 6 | import Data.Functor.Variant (inj, class VariantFMatchCases) 7 | import Prim.Row (class Cons, class Lacks) as Row 8 | import Prim.Row (class Union) 9 | import Prim.RowList (Cons, Nil) as RL 10 | import Prim.RowList (class RowToList, kind RowList) 11 | import Record (insert, get) as Record 12 | import Run (Run) 13 | import Run (on, onMatch, peel, run, send) as Run 14 | import Run.Reader (READER, Reader(..)) 15 | import Type.Prelude (class IsSymbol, Proxy(..)) 16 | import Unsafe.Coerce (unsafeCoerce) 17 | 18 | withReaderAt ∷ 19 | ∀ e1 e2 r_ r1 r2 s 20 | . IsSymbol s 21 | ⇒ Row.Cons s (Reader e1) r_ r1 22 | ⇒ Row.Cons s (Reader e2) r_ r2 23 | ⇒ Proxy s 24 | → (e2 → e1) 25 | → Run r1 26 | ~> Run r2 27 | withReaderAt sym f r = Run.run (Run.on sym handle (Run.send >>> expand' sym)) r 28 | where 29 | expand' ∷ ∀ l b t t_. Row.Cons l b t_ t ⇒ Proxy l → Run t_ ~> Run t 30 | expand' _ = unsafeCoerce 31 | 32 | handle (Reader k) = Run.send (inj sym (Reader (k <<< f))) 33 | 34 | 35 | 36 | -- -- | Example usage 37 | -- 38 | -- -- | This is for sure ugly but could be probably 39 | -- -- | constructed from plain value record `{ x: 8, y: "test" }` 40 | -- context = { x: 8, y: "test" } 41 | -- 42 | -- usingReaders :: forall eff. Run (x :: READER Int, y :: READER String | eff) String 43 | -- usingReaders = do 44 | -- i ← askAt (Proxy ∷ Proxy "x") 45 | -- s ← askAt (Proxy ∷ Proxy "y") 46 | -- pure $ s <> show i 47 | -- 48 | -- interpreted :: forall eff. Run eff String 49 | -- interpreted = runReaders context usingReaders 50 | -- | Turn record of values into a record of 51 | -- | `Reader k` applications so we can use it 52 | -- | when dispaching readers over the context. 53 | -- | 54 | -- | { x: 8 } 55 | -- | 56 | -- | into 57 | -- | 58 | -- | { x: \(Reader k) → Left (k 8) } 59 | -- | 60 | class RunReaders (il ∷ RowList Type) (i ∷ Row Type) (o ∷ Row Type) | il → o where 61 | runReadersImpl ∷ Proxy il → { | i } → { | o } 62 | 63 | instance runReadersNil ∷ RunReaders RL.Nil i () where 64 | runReadersImpl _ _ = {} 65 | 66 | instance runReadersCons ∷ 67 | ( IsSymbol s 68 | , Row.Lacks s o_ 69 | , RunReaders t i o_ 70 | , Row.Cons s e i_ i 71 | , Row.Cons s (Reader e a → Either a b) o_ o 72 | , RunReaders t i o_ 73 | ) ⇒ 74 | RunReaders (RL.Cons s e t) i o where 75 | runReadersImpl _ i = 76 | let 77 | l = Proxy ∷ Proxy s 78 | 79 | o_ = runReadersImpl (Proxy ∷ Proxy t) i 80 | in 81 | Record.insert l (\(Reader k) → Left (k (Record.get l i))) o_ 82 | 83 | runReaders ∷ 84 | ∀ r r' rl rl' r1 r2 r3 a. 85 | RowToList r rl ⇒ 86 | RunReaders rl r r' ⇒ 87 | RowToList r' rl' ⇒ 88 | VariantFMatchCases rl' r1 (Run r3 a) (Either (Run r3 a) (Run r2 (Run r3 a))) ⇒ 89 | Union r1 r2 r3 ⇒ 90 | Record r → 91 | Run r3 a → 92 | Run r2 a 93 | runReaders e = loop 94 | where 95 | e' = runReadersImpl (Proxy ∷ Proxy rl) e 96 | 97 | handle = Run.onMatch e' (Run.send >>> Right) 98 | 99 | loop r = case Run.peel r of 100 | Left a → case handle a of 101 | Left k → loop k 102 | Right a' → a' >>= loop 103 | Right a → pure a 104 | -------------------------------------------------------------------------------- /src/WebRow/Crypto.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Crypto 2 | ( _crypto 3 | , run 4 | , secret 5 | , signJson 6 | , sign 7 | , unsignJson 8 | , unsign 9 | , CRYPTO 10 | , Crypto 11 | , module Types 12 | ) where 13 | 14 | import Prelude 15 | 16 | import Data.Argonaut (Json) 17 | import Data.Either (Either(..)) 18 | import HTTPure (empty) as Headers 19 | import Run (Run) 20 | import Run.Reader (Reader, askAt, runReaderAt) 21 | import Type.Row (type (+)) 22 | import Type.Prelude (Proxy(..)) 23 | import WebRow.Crypto.Jwt.Node (UnsignError) 24 | import WebRow.Crypto.Jwt.Node (sign, unsign) as Jwt 25 | import WebRow.Crypto.Jwt.Node.String (sign, unsign) as String 26 | import WebRow.Crypto.Types (Secret(..)) as Types 27 | import WebRow.Crypto.Types (Secret) 28 | import WebRow.HTTP.Response.Except (HTTPEXCEPT, internalServerError) 29 | import WebRow.HTTP.Response.Types (Body(..)) 30 | 31 | _crypto = Proxy ∷ Proxy "crypto" 32 | 33 | type Crypto = Reader Secret 34 | 35 | type CRYPTO r = ( crypto ∷ Crypto | r ) 36 | 37 | secret ∷ ∀ eff. Run (CRYPTO + eff) Secret 38 | secret = askAt _crypto 39 | 40 | -- | TODO: Should we handle errors through custom exception? 41 | signJson ∷ 42 | ∀ eff. 43 | Json → 44 | Run (CRYPTO + HTTPEXCEPT + eff) String 45 | signJson json = do 46 | sec ← askAt _crypto 47 | case Jwt.sign sec json of 48 | Left _ → internalServerError Headers.empty $ BodyString "Serious problem..." 49 | Right s → pure s 50 | 51 | sign ∷ 52 | ∀ eff. 53 | String → 54 | Run (CRYPTO + HTTPEXCEPT + eff) String 55 | sign str = do 56 | sec ← askAt _crypto 57 | case String.sign sec str of 58 | Left _ → internalServerError Headers.empty $ BodyString "Serious problem..." 59 | Right s → pure s 60 | 61 | unsignJson ∷ 62 | ∀ eff. 63 | String → 64 | Run (CRYPTO + eff) (Either UnsignError Json) 65 | unsignJson json = askAt _crypto <#> \s → Jwt.unsign s json 66 | 67 | unsign ∷ 68 | ∀ eff. 69 | String → 70 | Run (CRYPTO + eff) (Either UnsignError String) 71 | unsign json = do 72 | askAt _crypto <#> \s → String.unsign s json 73 | 74 | run ∷ ∀ eff. Secret → Run (CRYPTO + eff) ~> Run eff 75 | run s = runReaderAt _crypto s 76 | -------------------------------------------------------------------------------- /src/WebRow/Crypto/Jwt.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Crypto.Jwt where 2 | 3 | import Prelude 4 | import Data.Argonaut (jsonParser) as Argonaut 5 | import Data.Either (hush) 6 | import Data.Maybe (Maybe(..)) 7 | import Data.String (split) as String 8 | import Data.String.Base64 (decode) as Base64 9 | import Data.String.Pattern (Pattern(..)) 10 | import WebRow.Crypto.Types (Unverified(..)) 11 | 12 | unverified ∷ 13 | String → 14 | Maybe Unverified 15 | unverified jwt = case String.split (Pattern ".") jwt of 16 | [ _, payloadSegment, _ ] → do 17 | payload ← hush $ Base64.decode payloadSegment 18 | json ← hush $ Argonaut.jsonParser payload 19 | pure $ Unverified json 20 | otherwise → Nothing 21 | -------------------------------------------------------------------------------- /src/WebRow/Crypto/Jwt/Node.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Crypto.Jwt.Node where 2 | 3 | import Prelude 4 | import Data.Argonaut (Json) 5 | import Data.Either (Either(..)) 6 | import Effect.Exception (Error, catchException) as Effect 7 | import Effect.Unsafe (unsafePerformEffect) 8 | import Foreign (Foreign) 9 | import Node.Simple.Jwt (Algorithm(..), decode, encode, fromString, toString) as Jwt 10 | import Node.Simple.Jwt (JwtError) 11 | import Unsafe.Coerce (unsafeCoerce) 12 | import WebRow.Crypto.Types (Secret(..)) 13 | 14 | data UnsignError 15 | = JwtError JwtError 16 | | PossibleDecodingError Effect.Error 17 | 18 | data SignError 19 | = PossibleEncodingError Effect.Error 20 | 21 | sign ∷ 22 | Secret → 23 | Json → 24 | Either SignError String 25 | sign (Secret secret) json = unsafePerformEffect $ Effect.catchException (pure <<< Left <<< PossibleEncodingError) s 26 | where 27 | jsonToForeign ∷ Json → Foreign 28 | jsonToForeign = unsafeCoerce 29 | 30 | s = (Right <<< Jwt.toString) <$> (Jwt.encode secret Jwt.HS512 (jsonToForeign json)) 31 | 32 | unsign ∷ 33 | Secret → 34 | String → 35 | Either UnsignError Json 36 | unsign (Secret secret) str = unsafePerformEffect $ Effect.catchException (pure <<< Left <<< PossibleDecodingError) u 37 | where 38 | fromForeingJson ∷ Foreign → Json 39 | fromForeingJson = unsafeCoerce 40 | 41 | u = 42 | Jwt.decode secret (Jwt.fromString str) 43 | >>= case _ of 44 | Left err → pure $ Left $ JwtError err 45 | Right payload → pure $ Right (fromForeingJson payload) 46 | -------------------------------------------------------------------------------- /src/WebRow/Crypto/Jwt/Node/String.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Crypto.Jwt.Node.String where 2 | 3 | import Prelude 4 | import Data.Argonaut (fromString, toString) as Argonaut 5 | import Data.Either (Either, note) 6 | import Effect.Exception (error) as Effect 7 | import JS.Unsafe.Stringify (unsafeStringify) 8 | import WebRow.Crypto.Jwt.Node (SignError, UnsignError(..)) 9 | import WebRow.Crypto.Jwt.Node (sign, unsign) as Jwt 10 | import WebRow.Crypto.Types (Secret) 11 | 12 | sign ∷ 13 | Secret → 14 | String → 15 | Either SignError String 16 | sign secret = Jwt.sign secret <<< Argonaut.fromString 17 | 18 | unsign ∷ 19 | Secret → 20 | String → 21 | Either UnsignError String 22 | unsign secret s = 23 | note (PossibleDecodingError (Effect.error (unsafeStringify s))) 24 | <<< Argonaut.toString 25 | <=< Jwt.unsign secret 26 | $ s 27 | -------------------------------------------------------------------------------- /src/WebRow/Crypto/Types.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Crypto.Types where 2 | 3 | import Data.Argonaut (Json) 4 | import Data.Newtype (class Newtype) 5 | 6 | newtype Secret 7 | = Secret String 8 | 9 | newtype Signed 10 | = Signed String 11 | 12 | newtype Unsigned 13 | = Unsigned String 14 | 15 | derive instance newtypeUnsigned ∷ Newtype Unsigned _ 16 | 17 | newtype Unverified 18 | = Unverified Json 19 | 20 | derive instance newtypeUnverified ∷ Newtype Unverified _ 21 | -------------------------------------------------------------------------------- /src/WebRow/Devel/Server/Static.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Devel.Server.Static where 2 | 3 | import Prelude 4 | import Control.Monad.Error.Class (catchError) 5 | import Data.Array (last) 6 | import Data.Map (Map, lookup) 7 | import Data.Map (fromFoldable) as Map 8 | import Data.Maybe (maybe) 9 | import Data.String (Pattern(..), split) 10 | import Data.String (joinWith) as String 11 | import Data.Tuple (Tuple(..)) 12 | import Data.Undefined.NoProblem (Opt, (!)) 13 | import Data.Undefined.NoProblem.Closed (class Coerce, coerce) 14 | import Effect (Effect) 15 | import Effect.Aff (Aff) 16 | import Effect.Aff.Class (class MonadAff, liftAff) 17 | import Effect.Class.Console (log) 18 | import HTTPure (header, notFound, ok', serve) as HTTPure 19 | import HTTPure.Response (Response) as HTTPure.Response 20 | import Node.Buffer (Buffer) 21 | import Node.FS.Aff (readFile) as FS 22 | import Unsafe.Coerce (unsafeCoerce) 23 | 24 | htaccess ∷ Map String String 25 | htaccess = 26 | Map.fromFoldable 27 | $ [ Tuple "aab" "application/x-authorware-bin" 28 | , Tuple "aam" "application/x-authorware-map" 29 | , Tuple "aas" "application/x-authorware-seg" 30 | , Tuple "asc" "text/plain" 31 | , Tuple "asf" "video/x-ms-asf" 32 | , Tuple "asp" "text/html" 33 | , Tuple "asx" "video/x-ms-asf" 34 | , Tuple "avi" "application/octet-stream" 35 | , Tuple "awk" "text/plain" 36 | , Tuple "bash" "text/plain" 37 | , Tuple "bsh" "text/plain" 38 | , Tuple "bz2" "application/octet-stream" 39 | , Tuple "c" "text/plain" 40 | , Tuple "cgi" "text/plain" 41 | , Tuple "chm" "application/octet-stream" 42 | , Tuple "class" "application/x-java-applet" 43 | , Tuple "csh" "text/plain" 44 | , Tuple "css" "text/css" 45 | , Tuple "csv" "application/vnd.ms-excel" 46 | , Tuple "dcr" "application/x-director" 47 | , Tuple "dir" "application/x-director" 48 | , Tuple "dmg" "application/octet-stream" 49 | , Tuple "dxr" "application/x-director" 50 | , Tuple "exe" "application/octet-stream" 51 | , Tuple "fgd" "application/x-director" 52 | , Tuple "fh" "image/x-freehand" 53 | , Tuple "fh4" "image/x-freehand" 54 | , Tuple "fh5" "image/x-freehand" 55 | , Tuple "fh7" "image/x-freehand" 56 | , Tuple "fhc" "image/x-freehand" 57 | , Tuple "flv" "video/x-flv" 58 | , Tuple "gawk" "text/plain" 59 | , Tuple "gtar" "application/x-gtar" 60 | , Tuple "gz" "application/x-gzip" 61 | , Tuple "h" "text/plain" 62 | , Tuple "html" "text/html" 63 | , Tuple "ico" "image/vnd.microsoft.icon" 64 | , Tuple "in" "text/plain" 65 | , Tuple "ini" "text/plain" 66 | , Tuple "m3u" "audio/x-mpegurl" 67 | , Tuple "md5" "text/plain" 68 | , Tuple "mov" "application/octet-stream" 69 | , Tuple "mov" "video/quicktime" 70 | , Tuple "mp4" "application/octet-stream" 71 | , Tuple "mpg" "application/octet-stream" 72 | , Tuple "msi" "application/octet-stream" 73 | , Tuple "nawk" "text/plain" 74 | , Tuple "pdb" "application/x-pilot" 75 | , Tuple "pdf" "application/pdf" 76 | , Tuple "phps" "application/x-httpd-php-source" 77 | , Tuple "pl" "text/plain" 78 | , Tuple "prc" "application/x-pilot" 79 | , Tuple "py" "text/plain" 80 | , Tuple "qt" "video/quicktime" 81 | , Tuple "ra" "audio/vnd.rn-realaudio" 82 | , Tuple "ram" "audio/vnd.rn-realaudio" 83 | , Tuple "rar" "application/x-rar-compressed" 84 | , Tuple "rm" "application/vnd.rn-realmedia" 85 | , Tuple "rpm" "audio/x-pn-realaudio-plugin" 86 | , Tuple "rv" "video/vnd.rn-realvideo" 87 | , Tuple "sh" "text/plain" 88 | , Tuple "sha" "text/plain" 89 | , Tuple "sha1" "text/plain" 90 | , Tuple "shtml" "text/html" 91 | , Tuple "svg" "image/svg+xml" 92 | , Tuple "svgz" "image/svg+xml" 93 | , Tuple "swf" "application/x-shockwave-flash" 94 | , Tuple "tgz" "application/octet-stream" 95 | , Tuple "torrent" "application/x-bittorrent" 96 | , Tuple "var" "text/plain" 97 | , Tuple "wav" "audio/x-wav" 98 | , Tuple "wax" "audio/x-ms-wax" 99 | , Tuple "wm" "video/x-ms-wm" 100 | , Tuple "wma" "audio/x-ms-wma" 101 | , Tuple "wmd" "application/x-ms-wmd" 102 | , Tuple "wmv" "video/x-ms-wmv" 103 | , Tuple "wmx" "video/x-ms-wmx" 104 | , Tuple "wmz" "application/x-ms-wmz" 105 | , Tuple "wvx" "video/x-ms-wvx" 106 | , Tuple "xbm" "image/x-xbitmap" 107 | , Tuple "xhtml" "application/xhtml+xml" 108 | , Tuple "xls" "application/octet-stream" 109 | , Tuple "xml" "text/xml" 110 | , Tuple "xrdf" "application/xrds+xml" 111 | , Tuple "zip" "application/zip" 112 | ] 113 | 114 | serveFile ∷ ∀ m. MonadAff m ⇒ String → m HTTPure.Response.Response 115 | serveFile fileName = do 116 | let 117 | ext = last $ split (Pattern ".") fileName 118 | 119 | contentType = maybe "*/*" identity (ext >>= flip lookup htaccess) 120 | 121 | headers = HTTPure.header "Content-Type" contentType 122 | let 123 | notFoundHandler = 124 | const 125 | $ do 126 | log $ "File not found: " <> fileName 127 | HTTPure.notFound 128 | -- | TODO: make this efficient 129 | liftAff 130 | $ ((FS.readFile fileName ∷ Aff Buffer) >>= HTTPure.ok' headers) 131 | `catchError` 132 | notFoundHandler 133 | 134 | static ∷ ∀ m. MonadAff m ⇒ String → Array String → m HTTPure.Response.Response 135 | static dir subpath = serveFile $ String.joinWith "/" ([ dir ] <> subpath) 136 | 137 | type Options 138 | = { dir ∷ String 139 | , port ∷ Opt Int 140 | } 141 | 142 | -- | Use this version when calling from PS 143 | safe ∷ ∀ opts. Coerce opts Options ⇒ opts → Effect (Effect Unit) 144 | safe opts = do 145 | let 146 | opts' = coerce opts ∷ Options 147 | 148 | port = opts'.port ! 8000 149 | 150 | msg = "Serving static files from " <> opts'.dir <> " on: http://0.0.0.0:" <> show port 151 | close ← HTTPure.serve port (\req → static opts'.dir req.path) (log msg) 152 | pure (close $ pure unit) 153 | 154 | -- | Use this version when calling directly from JS 155 | unsafe ∷ ∀ opts. opts → Effect (Effect Unit) 156 | unsafe opts = safe (unsafeCoerce opts ∷ Options) 157 | -------------------------------------------------------------------------------- /src/WebRow/Forms.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms 2 | ( module Bi 3 | , module Layout 4 | , module Uni 5 | , module Widgets 6 | ) where 7 | 8 | import WebRow.Forms.Bi (Bi) as Bi 9 | import WebRow.Forms.Uni (Uni) as Uni 10 | import WebRow.Forms.Widgets (TextInput) as Widgets 11 | import WebRow.Forms.Layout (Layout, LayoutBase(..)) as Layout 12 | -------------------------------------------------------------------------------- /src/WebRow/Forms/Bi/Builder.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms.Bi.Builder where 2 | 3 | import Prelude 4 | import Data.Newtype (class Newtype, un) 5 | import Data.Profunctor (class Profunctor, dimap, lcmap) 6 | import Polyform (Dual(..)) 7 | import Polyform.Batteries.UrlEncoded (Query) as UrlEncoded 8 | import Polyform.Reporter.Dual (DualD, Dual) as Reporter 9 | import WebRow.Forms.BuilderM (BuilderM) 10 | 11 | type Default layout 12 | = { layout ∷ layout 13 | , overwrite ∷ UrlEncoded.Query → layout 14 | , payload ∷ UrlEncoded.Query 15 | } 16 | 17 | -- | I'm not sure if we want to carry this `n` 18 | -- | parameter. This disticion is useful 19 | -- | in some scenarios but is it worth such 20 | -- | a type complication? 21 | newtype BuilderD m layout i o' o 22 | = BuilderD 23 | ( BuilderM 24 | { dualD ∷ Reporter.DualD m layout i o' o 25 | , default ∷ Default layout 26 | } 27 | ) 28 | 29 | derive instance functorBuilderD ∷ Functor m ⇒ Functor (BuilderD m layout i o') 30 | 31 | instance applyBuilderD ∷ (Monoid layout, Semigroup i, Monad m) ⇒ Apply (BuilderD m layout i o') where 32 | apply (BuilderD sw1) (BuilderD sw2) = 33 | BuilderD 34 | $ do 35 | w1 ← sw1 36 | w2 ← sw2 37 | pure 38 | { dualD: apply w1.dualD w2.dualD 39 | , default: w1.default <> w2.default 40 | } 41 | 42 | instance applicativeBuilderD ∷ 43 | (Monoid i, Monoid layout, Monad m) ⇒ 44 | Applicative (BuilderD m layout i o') where 45 | pure a = 46 | BuilderD 47 | $ pure 48 | { dualD: pure a 49 | , default: mempty 50 | } 51 | 52 | instance profunctorBuilderD ∷ 53 | (Functor m) ⇒ 54 | Profunctor (BuilderD m layout i) where 55 | dimap l r (BuilderD w) = 56 | BuilderD do 57 | { dualD, default: def } ← w 58 | pure { dualD: dimap l r dualD, default: def } 59 | 60 | newtype Builder m layout i o 61 | = Builder (BuilderD m layout i o o) 62 | 63 | derive instance newtypeBuilder ∷ Newtype (Builder m layout i o) _ 64 | 65 | instance semigroupoidBuilder ∷ (Monoid layout, Monad m) ⇒ Semigroupoid (Builder m layout) where 66 | compose (Builder (BuilderD sw1)) (Builder (BuilderD sw2)) = 67 | Builder $ BuilderD 68 | $ do 69 | w1 ← sw1 70 | w2 ← sw2 71 | pure 72 | { dualD: un Dual (compose (Dual w1.dualD) (Dual w2.dualD)) 73 | , default: w1.default <> w2.default 74 | } 75 | 76 | instance categoryBuilder ∷ (Monoid layout, Monad m) ⇒ Category (Builder m layout) where 77 | identity = Builder $ BuilderD $ pure { dualD: un Dual identity, default: mempty } 78 | 79 | infixl 5 diverge as ~ 80 | 81 | diverge ∷ 82 | ∀ layout i m o o'. 83 | Functor m ⇒ 84 | (o' → o) → 85 | Builder m layout i o → 86 | BuilderD m layout i o' o 87 | diverge f = lcmap f <<< un Builder 88 | 89 | fromDual ∷ 90 | ∀ i layout m o. 91 | Monoid layout ⇒ 92 | Applicative m ⇒ 93 | Reporter.Dual m layout i o → 94 | Builder m layout i o 95 | fromDual (Dual d) = Builder $ BuilderD (pure { default: mempty, dualD: d }) 96 | 97 | builder ∷ 98 | ∀ i layout m o. 99 | BuilderM 100 | { default ∷ Default layout 101 | , dualD ∷ Reporter.DualD m layout i o o 102 | } → 103 | Builder m layout i o 104 | builder = Builder <<< BuilderD 105 | -------------------------------------------------------------------------------- /src/WebRow/Forms/Bi/Form.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms.Bi.Form where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Writer (mapWriterT) 6 | import Data.Lens (over) as Lens 7 | import Data.Lens.Record (prop) 8 | import Data.Maybe (Maybe) 9 | import Data.Profunctor.Strong (second) 10 | import Data.Tuple.Nested (type (/\)) 11 | import Polyform (Dual(..)) 12 | import Polyform.Batteries.UrlEncoded (Query) as UrlEncoded 13 | import Polyform.Dual (hoistParser, parser) as Dual 14 | import Polyform.Dual (hoistSerializer) 15 | import Polyform.Reporter (lmapReporter) 16 | import Polyform.Reporter (runReporter) as Reporter 17 | import Polyform.Reporter.Dual (Dual, hoist, runSerializer) as Reporter.Dual 18 | import Type.Prelude (SProxy(..)) 19 | import WebRow.Forms.Bi.Builder (Builder(..), BuilderD(..)) 20 | import WebRow.Forms.Bi.Builder (Default) as Builder 21 | import WebRow.Forms.BuilderM (eval) as BuilderM 22 | import WebRow.Forms.Payload (UrlDecoded) 23 | 24 | -- | `m` in the context of `default` seems a bit 25 | -- | to restrictive but I'm not sure how to 26 | -- | limit here the build up process to something 27 | -- | like tranlsations / localizations etc. 28 | newtype Form m layout o 29 | = Form 30 | { dual ∷ Reporter.Dual.Dual m layout UrlDecoded o 31 | , default ∷ Builder.Default layout 32 | } 33 | 34 | -- | Should we change the order so layout is on the last position? 35 | -- | and we get a proper Functor instance for Form? 36 | -- | We are not able to provide any interesting instance for `o` because 37 | -- | it is part of the internal `Dual`. 38 | mapLayout ∷ ∀ layout layout' m o. Monad m ⇒ (layout → layout') → Form m layout o → Form m layout' o 39 | mapLayout f (Form r) = Form 40 | { dual: hoistSerializer (mapWriterT (map (second f))) <<< Dual.hoistParser (lmapReporter f) $ r.dual 41 | , default: 42 | Lens.over (prop (SProxy ∷ SProxy "overwrite")) (map f) 43 | $ Lens.over (prop (SProxy ∷ SProxy "layout")) f r.default 44 | } 45 | 46 | build ∷ ∀ m o widget. Builder m widget UrlDecoded o → Form m widget o 47 | build (Builder (BuilderD b)) = 48 | let 49 | { dualD, default } = BuilderM.eval b 50 | in 51 | Form { dual: Dual dualD, default } 52 | 53 | hoist ∷ 54 | ∀ layout m m' o. 55 | Functor m ⇒ 56 | (m ~> m') → 57 | Form m layout o → 58 | Form m' layout o 59 | hoist f (Form { default: d, dual }) = Form { default: d, dual: Reporter.Dual.hoist f dual } 60 | 61 | default ∷ 62 | ∀ layout m o. 63 | Form m layout o → 64 | Builder.Default layout 65 | default (Form { default: d }) = d 66 | 67 | serialize ∷ 68 | ∀ layout m o. 69 | Form m layout o → 70 | o → 71 | UrlEncoded.Query /\ layout 72 | serialize (Form { dual }) = Reporter.Dual.runSerializer $ dual 73 | 74 | validate ∷ 75 | ∀ layout m o. 76 | Monad m ⇒ 77 | Form m layout o → 78 | UrlDecoded → 79 | m (Maybe o /\ layout) 80 | validate (Form { dual }) = Reporter.runReporter (Dual.parser dual) 81 | 82 | -------------------------------------------------------------------------------- /src/WebRow/Forms/BuilderM.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms.BuilderM where 2 | 3 | import Prelude 4 | import Control.Monad.State (evalState) 5 | import Control.Monad.State (modify) as State 6 | import Control.Monad.State.Trans (StateT) 7 | import Data.Identity (Identity) 8 | 9 | -- | TODO: Add Reader to the stack with "form id" prefix. 10 | -- | It is needed when multiple forms are built separately and 11 | -- | displayed on the same site. 12 | newtype BuilderM a 13 | = BuilderM (StateT Int Identity a) 14 | 15 | derive newtype instance functorBuilderM ∷ Functor BuilderM 16 | 17 | derive newtype instance applyBuilderM ∷ Apply BuilderM 18 | 19 | derive newtype instance applicativeBuilderM ∷ Applicative BuilderM 20 | 21 | derive newtype instance bindBuilderM ∷ Bind BuilderM 22 | 23 | derive newtype instance monadBuilderM ∷ Monad BuilderM 24 | 25 | next ∷ BuilderM Int 26 | next = BuilderM $ State.modify (add 1) 27 | 28 | eval ∷ ∀ a. BuilderM a → a 29 | eval (BuilderM a) = evalState a 0 30 | 31 | id ∷ BuilderM String 32 | id = append "id" <<< show <$> next 33 | -------------------------------------------------------------------------------- /src/WebRow/Forms/Builders/Plain.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms.Builders.Plain where 2 | 3 | import Prelude 4 | 5 | -- import Data.Either (Either(..)) 6 | -- import Data.Map (lookup) as Map 7 | -- import Data.Maybe (Maybe(..)) 8 | -- import Data.Tuple (Tuple(..)) 9 | -- import Data.Validation.Semigroup (V(..)) 10 | -- import Data.Variant (Variant, inj) 11 | -- import JS.Unsafe.Stringify (unsafeStringify) 12 | -- import Polyform.Reporter (R(..), hoistFnMR) 13 | -- import Polyform.Reporter (Reporter) as Polyform.Reporter 14 | -- import Polyform.Reporter (hoistValidatorWith) as Reporter 15 | -- import Polyform.Validator (Validator(..)) as Polyform.Validator 16 | -- import Polyform.Validator (hoistFn) as Validator 17 | -- import Polyform.Validator (lmapValidator, runValidator) 18 | -- import Polyform.Validators.UrlEncoded (FieldValueValidator) 19 | -- import Type.Prelude (SProxy(..)) 20 | -- import Unsafe.Coerce (unsafeCoerce) 21 | -- import WebRow.Forms.Layout (Layout(..), closeSection, sectionReporter) as Layout 22 | -- import WebRow.Forms.Payload (Key) as Payload 23 | -- import WebRow.Forms.Payload (Value, UrlDecoded) 24 | -- import WebRow.Forms.Plain (Form(..)) as Plain 25 | -- import WebRow.Forms.Validation.Report (Result, Key) as Report 26 | -- import WebRow.Forms.Validation.Report (Result, Key) as Validation.Report 27 | -- import WebRow.Forms.Validation.Report (Result, Report) as Validation.Report 28 | -- import WebRow.Utils.Foreign.Object.Builder (Builder, insert) as Foreign.Object.Builder 29 | -- 30 | -- -- | Let's test this architecture in flatten monomoprhic 31 | -- -- | validation step result mode. 32 | -- type ReprRow = (repr ∷ String) 33 | -- 34 | -- type Repr = Variant ReprRow 35 | -- 36 | -- type Report = Validation.Report.Report Repr 37 | -- 38 | -- type Step = Foreign.Object.Builder.Builder (Validation.Report.Result Repr) 39 | -- 40 | -- type Reporter m i o = Polyform.Reporter.Reporter m Step i o 41 | -- 42 | -- data Field 43 | -- = InputField { name ∷ String, type_ ∷ String } 44 | -- 45 | -- type Layout = Layout.Layout Field Payload.Key Report.Key 46 | -- 47 | -- type Form m i o = Plain.Form m Layout Repr i o 48 | -- 49 | -- hoistValidator name = Reporter.hoistValidatorWith 50 | -- (toStep <<< Left) 51 | -- (toStep <<< Right <<< (inj (SProxy ∷ SProxy "repr") <<< unsafeStringify)) 52 | -- where 53 | -- toStep result = Foreign.Object.Builder.insert name result 54 | -- 55 | -- field 56 | -- ∷ ∀ m o 57 | -- . Monad m 58 | -- ⇒ { name ∷ String, type_ ∷ String } 59 | -- → FieldValueValidator m o 60 | -- → Form m UrlDecoded o 61 | -- field l@{ name, type_ } fieldValidator = Plain.Form { layout, reporter } 62 | -- where 63 | -- -- | TODO: Replace `name` based `Key` with 64 | -- -- | a proper id generation based on name and 65 | -- -- | some internal sequence. 66 | -- key = name 67 | -- reporter = hoistValidator 68 | -- key 69 | -- (Validator.hoistFn (Map.lookup key) >>> fieldValidator) 70 | -- 71 | -- layout = Layout.Field { input: key, field: InputField l, result: key } 72 | -- 73 | -- -- | TODO: Just for debugging 74 | -- passwordField ∷ ∀ o m. Monad m ⇒ String → FieldValueValidator m o → Form m UrlDecoded o 75 | -- passwordField name = field { name, type_: "password" } 76 | -- 77 | -- closeSection ∷ ∀ i m o. String → Form m i o → Form m i o 78 | -- closeSection title (Plain.Form { layout, reporter }) = Plain.Form 79 | -- { layout: Layout.closeSection title layout, reporter } 80 | -- 81 | -- sectionValidator ∷ ∀ i m o. Functor m ⇒ String → Polyform.Validator.Validator m (Array String) i o → Form m i o 82 | -- sectionValidator name validator = 83 | -- Plain.Form { layout: Layout.sectionReporter name, reporter } 84 | -- where 85 | -- reporter = hoistValidator name validator 86 | -- 87 | -------------------------------------------------------------------------------- /src/WebRow/Forms/Layout.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms.Layout where 2 | 3 | import Prelude 4 | 5 | import Data.Bifunctor (class Bifunctor, bimap) 6 | import Data.Foldable (class Foldable, foldMap, foldlDefault, foldrDefault) 7 | import Data.Generic.Rep (class Generic) 8 | import Data.List (List(..), singleton) as List 9 | import Data.List (List, (:)) 10 | import Data.Maybe (Maybe(..)) 11 | import Data.Traversable (class Traversable, sequence, traverse, traverseDefault) 12 | import WebRow.Forms.Widget (Widget) 13 | 14 | -- | Now when we have `VariantF` as a base widget representation and example 15 | -- | we can slowly move to this cleaner representation I think: 16 | -- | 17 | -- | ```purescript 18 | -- | data Layout (widget :: Type -> Type) msg 19 | -- | = Section (Array msg) (Array (Layout widget msg)) 20 | -- | | Widget (widget msg) 21 | -- | 22 | -- | derive instance functorLayout :: Functor widget => Functor (Layout widget) 23 | -- | 24 | -- | hoistWidget :: 25 | -- | forall msg widget widget'. 26 | -- | (widget ~> widget') -> Layout widget msg -> Layout widget' msg 27 | -- | hoistWidget f (Widget w) = Widget (f w) 28 | -- | hoistWidget f (Section msgs layouts) = Section msgs (map (hoistWidget f) layouts) 29 | -- | ``` 30 | 31 | -- | Because widegts has a row kind (# Type) I'm not able to 32 | -- | use this type directly. I would not be able 33 | -- | to provide instances for such a `Layout` type... 34 | type Layout message widget 35 | = LayoutBase message (Widget widget message) 36 | 37 | mapMessage ∷ ∀ message message' widget. (message → message') → Layout message widget → Layout message' widget 38 | mapMessage f l = bimap f (map f) l 39 | 40 | -- | `Layout` is a proposition for the form UI representation. 41 | -- | Provided DSLs in `Forms.Builders` depend on this structure 42 | -- | of a layout but in general you can switch layout representation 43 | -- | if you want to. Form types (`Forms.Plain` and `Form.Dual`) are polymorphic 44 | -- | over it. They just require a `Monoid` for a proper composition. 45 | -- | 46 | -- | This layout allows you to build tree like structure of sections 47 | -- | which can reference validation information related to a given 48 | -- | section. 49 | -- | Section can be "closed" by providing a title. "Closing" drives the 50 | -- | behaviour of monoidal `append` and allows you to build a tree. 51 | -- | 52 | -- | These references are filled out when validation process is finished. 53 | -- | Please check `Forms.Plain.run` or `Forms.Dual.run`. 54 | -- | 55 | type Header message 56 | = { id ∷ Maybe String, title ∷ Maybe message } 57 | 58 | type Section message widget 59 | = { closed ∷ Maybe (Header message) 60 | , errors ∷ Array message 61 | , layout ∷ List (LayoutBase message widget) 62 | } 63 | 64 | data LayoutBase message widget 65 | = Section (Section message widget) 66 | | Widget 67 | { id ∷ Maybe String 68 | , widget ∷ widget 69 | } 70 | 71 | derive instance functorLayoutBase ∷ Functor (LayoutBase message) 72 | 73 | derive instance eqLayoutBase ∷ (Eq message, Eq widget) ⇒ Eq (LayoutBase message widget) 74 | 75 | derive instance genericLayoutBase ∷ Generic (LayoutBase message widgets) _ 76 | 77 | instance foldableLayoutBase ∷ Foldable (LayoutBase message) where 78 | foldMap f (Widget { id, widget }) = f widget 79 | foldMap f (Section { layout }) = foldMap (foldMap f) layout 80 | foldr f = foldrDefault f 81 | foldl f = foldlDefault f 82 | 83 | instance traversableLayoutBase ∷ Traversable (LayoutBase message) where 84 | sequence (Widget { id, widget }) = Widget <<< { id, widget: _ } <$> widget 85 | sequence (Section { closed, errors, layout }) = Section <<< { closed, errors, layout: _ } <$> traverse sequence layout 86 | traverse f = traverseDefault f 87 | 88 | instance bifunctorLayoutBase ∷ Bifunctor LayoutBase where 89 | bimap f g (Section { closed, errors, layout }) = 90 | Section 91 | $ { closed: (\r → { id: r.id, title: f <$> r.title }) <$> closed 92 | , errors: map f errors 93 | , layout: bimap f g <$> layout 94 | } 95 | bimap f g (Widget { id, widget }) = Widget { id, widget: g widget } 96 | 97 | instance monoidLayoutBase ∷ Monoid (LayoutBase message widgets) where 98 | mempty = Section { closed: Nothing, errors: mempty, layout: mempty } 99 | 100 | 101 | -- + 102 | instance semigroupLayoutBase ∷ Semigroup (LayoutBase message widgets) where 103 | -- | TODO: This not nice and trivial strategy for combining form sections. 104 | -- | We can do better probably. 105 | append s1@(Section s1r) s2@(Section s2r) = case s1r.closed, s2r.closed of 106 | Nothing, Nothing → 107 | Section 108 | { closed: Nothing 109 | , errors: s1r.errors <> s2r.errors 110 | , layout: s1r.layout <> s2r.layout 111 | } 112 | Just _, Just _ → 113 | Section 114 | { closed: Nothing 115 | , errors: mempty 116 | , layout: s1 : s2 : List.Nil 117 | } 118 | Just _, Nothing → 119 | Section 120 | { closed: Nothing 121 | , errors: s2r.errors 122 | , layout: s1 : s2r.layout 123 | } 124 | Nothing, Just _ → 125 | Section 126 | { closed: Nothing 127 | , errors: s1r.errors 128 | , layout: s1r.layout <> (s2 : List.Nil) 129 | } 130 | append s@(Section sr) widget@(Widget _) = case sr.closed of 131 | Nothing → 132 | Section 133 | { closed: Nothing 134 | , errors: sr.errors 135 | , layout: sr.layout <> List.singleton widget 136 | } 137 | otherwise → 138 | Section 139 | { closed: Nothing 140 | , errors: mempty 141 | , layout: s : widget : List.Nil 142 | } 143 | append widget@(Widget _) s@(Section sr) = case sr.closed of 144 | Nothing → 145 | Section 146 | { closed: Nothing 147 | , errors: sr.errors 148 | , layout: widget : sr.layout 149 | } 150 | otherwise → 151 | Section 152 | { closed: Nothing 153 | , errors: mempty 154 | , layout: widget : s : List.Nil 155 | } 156 | append widget1@(Widget _) widget2@(Widget _) = 157 | Section 158 | { closed: Nothing 159 | , errors: mempty 160 | , layout: widget1 : widget2 : List.Nil 161 | } 162 | 163 | closeSection ∷ ∀ message widgets. Header message → LayoutBase message widgets → LayoutBase message widgets 164 | closeSection header widgets@(Widget _) = Section { closed: Just header, layout: List.singleton widgets, errors: mempty } 165 | 166 | closeSection header widgets@(Section { layout, errors }) = Section { closed: Just header, layout, errors } 167 | 168 | sectionErrors ∷ ∀ message widgets. Array message → LayoutBase message widgets 169 | sectionErrors errors = Section { closed: Nothing, layout: mempty, errors } 170 | 171 | -------------------------------------------------------------------------------- /src/WebRow/Forms/Payload.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms.Payload where 2 | 3 | import Prelude 4 | import Data.Lazy (force) as L 5 | import Data.Maybe (Maybe, maybe) 6 | import Polyform.Batteries.UrlEncoded (Query) as UrlEncoded 7 | import Polyform.Batteries.UrlEncoded.Query (Key, lookup) as UrlDecoded.Query 8 | import Polyform.Batteries.UrlEncoded.Query (Value, parse) as UrlEncoded.Query 9 | import Run (Run) 10 | import Run.Reader (askAt) 11 | import Type.Row (type (+)) 12 | import WebRow.HTTP (HTTPEXCEPT, REQUEST, badRequest'', body) 13 | import WebRow.Routing (ROUTING, _routing) 14 | 15 | type Value 16 | = UrlEncoded.Query.Value 17 | 18 | type Key 19 | = UrlDecoded.Query.Key 20 | 21 | -- | Map String (Array String) 22 | type UrlDecoded 23 | = UrlEncoded.Query 24 | 25 | lookup ∷ String → UrlDecoded → Maybe (Array String) 26 | lookup = UrlDecoded.Query.lookup 27 | 28 | fromQuery ∷ ∀ eff route. Run (ROUTING route + eff) UrlDecoded 29 | fromQuery = 30 | pure 31 | <<< L.force 32 | <<< _.query 33 | =<< askAt _routing 34 | 35 | fromBody ∷ ∀ eff. Run (REQUEST + HTTPEXCEPT + eff) UrlDecoded 36 | fromBody = do 37 | bodyStr ← body 38 | maybe badRequest'' pure (UrlEncoded.Query.parse { replacePlus: true } bodyStr) 39 | -------------------------------------------------------------------------------- /src/WebRow/Forms/Uni/Builder.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms.Uni.Builder where 2 | 3 | import Prelude 4 | import Data.Newtype (class Newtype) 5 | import Polyform (Reporter) 6 | import WebRow.Forms.BuilderM (BuilderM) 7 | 8 | -- | We should differenciate monad here 9 | -- | for default and reporter so we can 10 | -- | build default layout without 11 | -- | using heavy context. 12 | newtype Builder m layout i o 13 | = Builder 14 | ( BuilderM 15 | { default ∷ layout 16 | , reporter ∷ Reporter m layout i o 17 | } 18 | ) 19 | 20 | derive instance newtypeBuilder ∷ Newtype (Builder m l i o) _ 21 | 22 | derive instance functorBuilder ∷ (Applicative m) ⇒ Functor (Builder m layout i) 23 | 24 | instance applyBuilder ∷ (Monad m, Monoid layout) ⇒ Apply (Builder m layout i) where 25 | apply (Builder sw1) (Builder sw2) = 26 | Builder 27 | $ do 28 | w1 ← sw1 29 | w2 ← sw2 30 | pure 31 | { default: w1.default <> w2.default 32 | , reporter: apply w1.reporter w2.reporter 33 | } 34 | 35 | instance applicativeBuilder ∷ (Monad m, Monoid layout) ⇒ Applicative (Builder m layout i) where 36 | pure a = 37 | Builder 38 | $ do 39 | pure 40 | { default: mempty 41 | , reporter: pure a 42 | } 43 | 44 | instance semigroupoidBuilder ∷ (Monad m, Monoid layout) ⇒ Semigroupoid (Builder m layout) where 45 | compose (Builder sw1) (Builder sw2) = 46 | Builder 47 | $ do 48 | w1 ← sw1 49 | w2 ← sw2 50 | pure 51 | { default: w1.default <> w2.default 52 | , reporter: compose w1.reporter w2.reporter 53 | } 54 | 55 | instance categoryBuilder ∷ (Monad m, Monoid layout) ⇒ Category (Builder m layout) where 56 | identity = 57 | Builder 58 | $ pure 59 | { default: mempty 60 | , reporter: identity 61 | } 62 | -------------------------------------------------------------------------------- /src/WebRow/Forms/Uni/Form.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms.Uni.Form where 2 | 3 | import Prelude 4 | import Data.Maybe (Maybe) 5 | import Data.Tuple (Tuple) 6 | import Polyform (Reporter) 7 | import Polyform.Reporter (runReporter) 8 | import WebRow.Forms.BuilderM (eval) as BuilderM 9 | import WebRow.Forms.Payload (UrlDecoded) 10 | import WebRow.Forms.Uni.Builder (Builder(..)) 11 | 12 | newtype Form m layout o 13 | = Form 14 | { default ∷ layout 15 | , reporter ∷ Reporter m layout UrlDecoded o 16 | } 17 | 18 | build ∷ ∀ layout m o. Builder m layout UrlDecoded o → Form m layout o 19 | build (Builder b) = Form (BuilderM.eval b) 20 | 21 | default :: forall layout m o. Form m layout o -> layout 22 | default (Form form) = _.default form 23 | 24 | validate ∷ 25 | ∀ layout m o. 26 | Functor m ⇒ 27 | Form m layout o → 28 | UrlDecoded → 29 | m (Tuple (Maybe o) layout) 30 | validate (Form { reporter }) i = runReporter reporter i 31 | -------------------------------------------------------------------------------- /src/WebRow/Forms/Validators.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms.Validators where 2 | 3 | import Prelude 4 | import Polyform.Batteries (Validator, error) as Batteries 5 | import Polyform.Validator (liftFnMaybe) as Validator 6 | import Type.Prelude (Proxy(..)) 7 | import Type.Row (type (+)) 8 | import WebRow.Mailer (Email) 9 | import WebRow.Mailer (email) as Mailer 10 | 11 | type Messages msgs 12 | = (InvalidEmailFormat + msgs) 13 | 14 | _invalidEmailFormat = Proxy ∷ Proxy "invalidEmailFormat" 15 | 16 | type InvalidEmailFormat r 17 | = ( invalidEmailFormat ∷ String | r ) 18 | 19 | email ∷ ∀ e m. Monad m ⇒ Batteries.Validator m ( invalidEmailFormat ∷ String | e ) String Email 20 | email = 21 | Validator.liftFnMaybe 22 | (Batteries.error _invalidEmailFormat msg) 23 | Mailer.email 24 | where 25 | msg = append "Invalid email format: " 26 | -------------------------------------------------------------------------------- /src/WebRow/Forms/Validators/Duals.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms.Validators.Duals where 2 | 3 | import Prelude 4 | import Data.Newtype (unwrap) 5 | import Polyform.Batteries (Dual) as Batteries 6 | import Polyform.Dual (dual) as Dual 7 | import WebRow.Forms.Validators (email) as Validators 8 | import WebRow.Mailer (Email) 9 | 10 | email ∷ ∀ e m. Monad m ⇒ Batteries.Dual m ( invalidEmailFormat ∷ String | e ) String Email 11 | email = Dual.dual Validators.email (unwrap >>> pure) 12 | -------------------------------------------------------------------------------- /src/WebRow/Forms/Widget.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms.Widget where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either) 6 | import Data.Foldable (class Foldable, foldr) 7 | import Data.Functor.Variant (VariantF) 8 | import Data.List (List(..), catMaybes, zip) as List 9 | import Data.Map (fromFoldable) as Map 10 | import Data.Maybe (Maybe) 11 | import Data.Traversable (class Traversable, for, sequence) 12 | import Polyform.Batteries.UrlEncoded (Query(..)) as UrlEncoded 13 | import WebRow.Forms.BuilderM (BuilderM) 14 | import WebRow.Forms.BuilderM (id) as BuilderM 15 | import WebRow.Forms.Payload (Key, UrlDecoded, Value, lookup) as Payload 16 | 17 | type Payload inputs 18 | = inputs (Maybe Payload.Value) 19 | 20 | type Names inputs 21 | = inputs Payload.Key 22 | 23 | type Widget widgets msg 24 | = VariantF widgets msg 25 | 26 | type Initials msg inputs o 27 | = { payload ∷ Payload inputs 28 | , names ∷ Names inputs 29 | , result ∷ Maybe (Either (Array msg) o) 30 | } 31 | 32 | type Constructor msg inputs widgets o 33 | = Initials msg inputs o → Widget widgets msg 34 | 35 | names ∷ 36 | ∀ inputs. 37 | Monoid (inputs Unit) ⇒ 38 | Traversable inputs ⇒ 39 | BuilderM (Names inputs) 40 | names = for (mempty ∷ inputs Unit) (\_ → BuilderM.id) 41 | 42 | -- | Extract payload from the query given a functor with names 43 | payload ∷ 44 | ∀ inputs. 45 | Functor inputs ⇒ 46 | inputs Payload.Key → 47 | Payload.UrlDecoded → 48 | Payload inputs 49 | payload inputs urlDecoded = map (flip Payload.lookup urlDecoded) inputs 50 | 51 | dump ∷ 52 | ∀ inputs. 53 | Foldable inputs ⇒ 54 | Names inputs → 55 | Payload inputs → 56 | Payload.UrlDecoded 57 | dump ns pl = 58 | UrlEncoded.Query 59 | <<< Map.fromFoldable 60 | -- | Drop empty values 61 | 62 | <<< List.catMaybes 63 | -- | Turn (Tuple k (Maybe v)) into (Maybe (Tuple k v)) 64 | 65 | <<< map sequence 66 | $ List.zip 67 | (foldr List.Cons List.Nil ns) 68 | (foldr List.Cons List.Nil pl) 69 | -------------------------------------------------------------------------------- /src/WebRow/Forms/Widgets.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Forms.Widgets where 2 | 3 | import Prelude 4 | import Data.Functor.Variant (inj) as VariantF 5 | import Data.Maybe (Maybe) 6 | import Data.Newtype (class Newtype) 7 | import Type.Prelude (Proxy(..)) 8 | import Type.Row (type (+)) 9 | import Unsafe.Coerce (unsafeCoerce) 10 | import WebRow.Forms.Payload (Value) as Payload 11 | import WebRow.Forms.Widget (Widget) 12 | 13 | _textInput = Proxy ∷ Proxy "textInput" 14 | 15 | type TextInputPropsRow attrs msg 16 | = ( label ∷ Maybe msg 17 | , payload ∷ Maybe Payload.Value 18 | , placeholder ∷ Maybe msg 19 | , helpText ∷ Maybe msg 20 | , name ∷ String 21 | , result ∷ Maybe (Maybe (Array msg)) 22 | , type_ ∷ String 23 | | attrs 24 | ) 25 | 26 | type TextInputPropsR attrs msg 27 | = { | TextInputPropsRow attrs msg } 28 | 29 | newtype TextInputProps attrs msg 30 | = TextInputProps (TextInputPropsR attrs msg) 31 | 32 | derive instance newtypeTextInputProps ∷ Newtype (TextInputProps attrs msg) _ 33 | 34 | derive instance functorTextInputProps ∷ Functor (TextInputProps attrs) 35 | 36 | instance eqTextInputProps ∷ (Eq { | attrs }, Eq msg) ⇒ Eq (TextInputProps attrs msg) where 37 | eq (TextInputProps p1) (TextInputProps p2) = do 38 | let 39 | contract ∷ { | TextInputPropsRow attrs msg } → { | TextInputPropsRow () msg } 40 | contract = unsafeCoerce 41 | 42 | rest ∷ { | TextInputPropsRow attrs msg } → { | attrs } 43 | rest = unsafeCoerce 44 | (contract p1 == contract p2) && (rest p1 == rest p2) 45 | 46 | type TextInput attrs r 47 | = ( textInput ∷ TextInputProps attrs | r ) 48 | 49 | textInput ∷ 50 | ∀ attrs msg r. 51 | TextInputPropsR attrs msg → 52 | Widget (TextInput attrs + r) msg 53 | textInput args = VariantF.inj _textInput (TextInputProps args) 54 | -------------------------------------------------------------------------------- /src/WebRow/Forms/Widgets/TextInput.purs: -------------------------------------------------------------------------------- 1 | module WebForm.Forms.Widgets.TextInput where 2 | 3 | -- import Prelude 4 | -- 5 | -- 6 | -- import Data.Functor.Variant (inj) as Functor.Variant 7 | -- import Data.Maybe (Maybe) 8 | -- import Data.Newtype (class Newtype) 9 | -- import Type.Prelude (SProxy(..)) 10 | -- import Type.Row (type (+)) 11 | -- import WebRow.Forms.Payload (Value) as Payload 12 | -- import WebRow.Forms.Widget (Widget) 13 | -- 14 | -- _textInput = SProxy ∷ SProxy "textInput" 15 | -- 16 | -- type TextInputPropsR onChange 17 | -- = { label ∷ Maybe String 18 | -- , payload ∷ Maybe Payload.Value 19 | -- , onChange ∷ String → onChange 20 | -- , placeholder ∷ Maybe String 21 | -- , helpText ∷ Maybe String 22 | -- , name ∷ String 23 | -- , result ∷ Maybe (Maybe (Array String)) 24 | -- , type_ ∷ String 25 | -- } 26 | -- 27 | -- newtype TextInputProps onChange 28 | -- = TextInputProps (TextInputPropsR onChange) 29 | -- derive instance functorTextInputProps ∷ Functor TextInputProps 30 | -- derive instance newtypeTextInputProps ∷ Newtype (TextInputProps onChange) _ 31 | -- 32 | -- type TextInput r 33 | -- = ( textInput ∷ Proxy TextInputProps 34 | -- | r 35 | -- ) 36 | -- 37 | -- textInput ∷ 38 | -- ∀ onChange r. 39 | -- TextInputPropsR onChange → 40 | -- Widget onChange (TextInput + r) 41 | -- textInput args = Functor.Variant.inj _textInput (TextInputProps args) 42 | -------------------------------------------------------------------------------- /src/WebRow/HTTP.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP 2 | ( module Cookies 3 | , module Response.Except 4 | , module Request 5 | , module Response 6 | ) where 7 | 8 | import WebRow.HTTP.Cookies (Cookies, COOKIES, CookieStore(..), RequestCookies, ResponseCookies) as Cookies 9 | import WebRow.HTTP.Response.Except (badGateway, badRequest, badRequest', badRequest'', forbidden, HTTPEXCEPT, HTTPExcept, HTTPException(..), internalServerError, internalServerError', methodNotAllowed, methodNotAllowed', notFound, notImplemented, redirect, serviceUnavailable, unauthorized) as Response.Except 10 | import WebRow.HTTP.Request (body, fullPath, header, headers, method, Request, REQUEST, query) as Request 11 | import WebRow.HTTP.Response (HTTPResponse(..), setHeader, SetHeader, SETHEADER) as Response 12 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Cookies.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Cookies 2 | ( Cookies 3 | , COOKIES 4 | , module Exports 5 | , _cookies 6 | , cookies 7 | , delete 8 | , lookup 9 | , lookup' 10 | , lookupJson 11 | , lookupJson' 12 | , run 13 | , runOnStore 14 | , set 15 | , setJson 16 | ) where 17 | 18 | import Prelude 19 | import Data.Argonaut (Json) 20 | import Data.Array.NonEmpty (NonEmptyArray) 21 | import Data.Foldable (for_) 22 | import Data.Lazy (Lazy) 23 | import Data.Maybe (Maybe(..)) 24 | import Data.Tuple (Tuple(..)) 25 | import Run (Run) 26 | import Run.State (State, getAt, putAt, runStateAt) 27 | import Type.Prelude (SProxy(..)) 28 | import Type.Row (type (+)) 29 | import WebRow.Contrib.Data.JSDate (epoch) 30 | import WebRow.Crypto (CRYPTO, secret) 31 | import WebRow.HTTP.Cookies.CookieStore (CookieStore(..)) as Exports 32 | import WebRow.HTTP.Cookies.CookieStore (CookieStore, cookieStore, toSetCookieHeaders) 33 | import WebRow.HTTP.Cookies.CookieStore (lookup, lookup', lookupJson, lookupJson', set, setJson) as CookieStore 34 | import WebRow.HTTP.Cookies.Types (Attributes, Name, SetValue, Value, Values, attributes) 35 | import WebRow.HTTP.Cookies.Types (attributes, Attributes(..), Name, Value, Values, RequestCookies, ResponseCookies, SetValue, defaultAttributes) as Exports 36 | import WebRow.HTTP.Request (REQUEST) 37 | import WebRow.HTTP.Request (headers) as Request 38 | import WebRow.HTTP.Response (setHeader, SETHEADER) as Response 39 | 40 | type Cookies = State CookieStore 41 | 42 | type COOKIES r = ( cookies ∷ Cookies | r ) 43 | 44 | _cookies = SProxy ∷ SProxy "cookies" 45 | 46 | cookies ∷ ∀ eff. Run (COOKIES + eff) CookieStore 47 | cookies = getAt _cookies 48 | 49 | lookup ∷ ∀ eff. Name → Run (COOKIES + eff) (Lazy (Maybe Value)) 50 | lookup name = CookieStore.lookup name <$> cookies 51 | 52 | lookup' ∷ ∀ eff. Name → Run (COOKIES + eff) (Lazy (Maybe Values)) 53 | lookup' name = CookieStore.lookup' name <$> cookies 54 | 55 | lookupJson ∷ ∀ eff. Name → Run (COOKIES + eff) (Lazy (Maybe Json)) 56 | lookupJson name = CookieStore.lookupJson name <$> cookies 57 | 58 | lookupJson' ∷ ∀ eff. Name → Run (COOKIES + eff) (Lazy (Maybe (NonEmptyArray Json))) 59 | lookupJson' name = CookieStore.lookupJson' name <$> cookies 60 | 61 | -- | TODO: We should handle here cookie errors like "to large cookies" etc. 62 | set ∷ ∀ eff. Name → SetValue → Run (COOKIES + eff) Boolean 63 | set name v = do 64 | cookies' ← CookieStore.set name v <$> cookies 65 | case cookies' of 66 | Just c → do 67 | putAt _cookies c 68 | pure true 69 | Nothing → pure false 70 | 71 | setJson ∷ ∀ eff. Name → { json ∷ Json, attributes ∷ Attributes } → Run (COOKIES + eff) Boolean 72 | setJson name v = do 73 | cookies' ← CookieStore.setJson name v <$> cookies 74 | case cookies' of 75 | Just c → do 76 | putAt _cookies c 77 | pure true 78 | Nothing → pure false 79 | 80 | delete ∷ ∀ eff. Name → Run (COOKIES + eff) Boolean 81 | delete name = set name { value: "", attributes: attributes _ { expires = Just epoch } } 82 | 83 | -- | Useful for testing when we want 84 | -- | to provide store directly and not 85 | -- | print and parse headers. 86 | runOnStore ∷ 87 | ∀ a eff. 88 | CookieStore → 89 | Run (COOKIES + Response.SETHEADER + eff) a → 90 | Run (Response.SETHEADER + eff) a 91 | runOnStore c action = do 92 | (Tuple cs a) ← runStateAt _cookies c action 93 | let 94 | headers = toSetCookieHeaders cs 95 | for_ headers \(Tuple k v) → do 96 | Response.setHeader k v 97 | pure a 98 | 99 | run ∷ 100 | ∀ a eff. 101 | Run (COOKIES + CRYPTO + REQUEST + Response.SETHEADER + eff) a → 102 | Run (CRYPTO + REQUEST + Response.SETHEADER + eff) a 103 | run action = do 104 | s ← secret 105 | hs ← Request.headers 106 | runOnStore (cookieStore s hs) action 107 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Cookies/CookieStore.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Cookies.CookieStore where 2 | 3 | import Prelude 4 | import Data.Argonaut (Json) 5 | import Data.Array.NonEmpty (NonEmptyArray) 6 | import Data.Array.NonEmpty (head, singleton) as Array.NonEmpty 7 | import Data.Either (hush) 8 | import Data.Lazy (Lazy, defer) 9 | import Data.Lazy (force) as Lazy 10 | import Data.Map (empty, insert, lookup, toUnfoldable) as Map 11 | import Data.Maybe (Maybe(..)) 12 | import Data.Newtype (unwrap) 13 | import Data.Traversable (traverse) 14 | import Data.Tuple (Tuple(..)) 15 | import Foreign.Object as Object 16 | import HTTPure as HTTPure 17 | import WebRow.Contrib.Data.JSDate (epoch) 18 | import WebRow.Crypto (Secret) 19 | import WebRow.Crypto.Jwt.Node (sign, unsign) as Crypto.Jwt.Node 20 | import WebRow.Crypto.Jwt.Node.String (sign, unsign) as Crypto.String 21 | import WebRow.HTTP.Cookies.Headers (requestCookies, setCookieHeader) 22 | import WebRow.HTTP.Cookies.Types (Attributes) as Cookies 23 | import WebRow.HTTP.Cookies.Types (Name, RequestCookies, SetValue, Value, Values, ResponseCookies) 24 | 25 | newtype CookieStore 26 | = CookieStore 27 | { requestCookies ∷ Lazy RequestCookies 28 | , secret ∷ Secret 29 | , responseCookies ∷ ResponseCookies 30 | } 31 | 32 | cookieStore ∷ Secret → HTTPure.Headers → CookieStore 33 | cookieStore secret headers = 34 | CookieStore 35 | { requestCookies: defer \_ → requestCookies headers 36 | , secret 37 | , responseCookies: Map.empty 38 | } 39 | 40 | toSetCookieHeaders ∷ CookieStore → Array (Tuple String String) 41 | toSetCookieHeaders (CookieStore { responseCookies }) = 42 | responseCookies # Map.toUnfoldable 43 | >>> map \(Tuple name { attributes, value }) → 44 | setCookieHeader name value attributes 45 | 46 | lookup ∷ Name → CookieStore → Lazy (Maybe Value) 47 | lookup name = map (map Array.NonEmpty.head) <<< lookup' name 48 | 49 | lookup' ∷ Name → CookieStore → Lazy (Maybe Values) 50 | lookup' name (CookieStore { requestCookies, secret, responseCookies }) = defer f 51 | where 52 | f _ = signed >>= traverse unsign 53 | where 54 | unsign v = hush (Crypto.String.unsign secret v) 55 | 56 | signed = case name `Map.lookup` responseCookies of 57 | Just { value, attributes } 58 | | (unwrap attributes).expires /= Just epoch → Just (Array.NonEmpty.singleton value) 59 | Just _ → Nothing 60 | Nothing → name `Object.lookup` (Lazy.force requestCookies) 61 | 62 | -- | Because we are using JWT for payload encoding in cookie store we 63 | -- | are able to handle Json directly and we don't really have to 64 | -- | reencode anything two times. 65 | lookupJson ∷ Name → CookieStore → Lazy (Maybe Json) 66 | lookupJson name = map (map Array.NonEmpty.head) <<< lookupJson' name 67 | 68 | lookupJson' ∷ Name → CookieStore → Lazy (Maybe (NonEmptyArray Json)) 69 | lookupJson' name (CookieStore { requestCookies, secret, responseCookies }) = defer f 70 | where 71 | f _ = signed >>= traverse unsign 72 | where 73 | unsign v = hush (Crypto.Jwt.Node.unsign secret v) 74 | 75 | signed = case name `Map.lookup` responseCookies of 76 | Just { value, attributes } 77 | | (unwrap attributes).expires /= Just epoch → Just (Array.NonEmpty.singleton value) 78 | Just _ → Nothing 79 | Nothing → name `Object.lookup` (Lazy.force requestCookies) 80 | 81 | set ∷ Name → SetValue → CookieStore → Maybe CookieStore 82 | set name { value, attributes } (CookieStore { requestCookies, secret, responseCookies }) = ado 83 | value' ← hush (Crypto.String.sign secret value) 84 | in CookieStore 85 | { requestCookies 86 | , secret 87 | , responseCookies: Map.insert name { attributes, value: value' } responseCookies 88 | } 89 | 90 | -- | Because we are using jwt for payload encoding 91 | -- | we can handle json directly. 92 | setJson ∷ Name → { json ∷ Json, attributes ∷ Cookies.Attributes } → CookieStore → Maybe CookieStore 93 | setJson name { json, attributes } (CookieStore { requestCookies, secret, responseCookies }) = ado 94 | value' ← hush (Crypto.Jwt.Node.sign secret json) 95 | in CookieStore 96 | { requestCookies 97 | , secret 98 | , responseCookies: Map.insert name { attributes, value: value' } responseCookies 99 | } 100 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Cookies/Headers.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Cookies.Headers where 2 | 3 | import Prelude 4 | import Control.Monad.Error.Class (throwError) 5 | import Data.Array (catMaybes, filter) 6 | import Data.Array.NonEmpty (singleton) as Array.NonEmpty 7 | import Data.Either (Either, hush) 8 | import Data.JSDate (toUTCString) 9 | import Data.Maybe (Maybe(..), fromMaybe) 10 | import Data.String (Pattern(..), joinWith, split, trim) 11 | import Data.Traversable (sequence) 12 | import Data.Tuple (Tuple(..)) 13 | import Foreign.Object as Object 14 | import HTTPure (Headers, lookup) as HTTPure 15 | import Run (EFFECT, Run) 16 | import Type.Row (type (+)) 17 | import WebRow.Contrib.JSURI (unsafeDecodeURIComponent, unsafeEncodeURIComponent) 18 | import WebRow.Crypto (CRYPTO) 19 | import WebRow.HTTP.Cookies.Types (Attributes(..), Name, RequestCookies, SameSite(..), SetValue, Value, Values) 20 | import WebRow.HTTP.Response (SETHEADER, setHeader) as HTTP.Response 21 | 22 | requestCookies ∷ HTTPure.Headers → RequestCookies 23 | requestCookies hs = 24 | fromMaybe mempty 25 | $ hush 26 | <<< parseCookies 27 | =<< HTTPure.lookup hs cookieHeaderKey 28 | 29 | setCookie ∷ 30 | ∀ eff. 31 | Name → 32 | SetValue → 33 | Run (EFFECT + CRYPTO + HTTP.Response.SETHEADER + eff) Unit 34 | setCookie name { value, attributes } = do 35 | let 36 | h = setCookieHeaderValue name value attributes 37 | HTTP.Response.setHeader setCookieHeaderKey h 38 | 39 | cookieHeaderKey ∷ String 40 | cookieHeaderKey = "cookie" 41 | 42 | setCookieHeaderKey ∷ String 43 | setCookieHeaderKey = "Set-Cookie" 44 | 45 | setCookieHeader ∷ Name → Value → Attributes → Tuple String String 46 | setCookieHeader n v attrs = Tuple setCookieHeaderKey (setCookieHeaderValue n v attrs) 47 | 48 | -- | XXX: Add cookie size check here 49 | setCookieHeaderValue ∷ Name → Value → Attributes → String 50 | setCookieHeaderValue key value (Attributes { comment, expires, path, maxAge, domain, secure, httpOnly, sameSite }) = 51 | [ Just $ assign (unsafeEncodeURIComponent key) (unsafeEncodeURIComponent value) 52 | , (assign "Comment" <<< unsafeEncodeURIComponent) <$> comment 53 | , (assign "Expires" <<< toUTCString) <$> expires 54 | , (assign "Max-Age" <<< show) <$> maxAge 55 | , assign "Domain" <$> domain 56 | , assign "Path" <$> path 57 | , assign "SameSite" <<< sameSiteSer <$> sameSite 58 | , if secure then Just "Secure" else Nothing 59 | , if httpOnly then Just "HttpOnly" else Nothing 60 | ] 61 | # catMaybes 62 | # joinWith ";" 63 | where 64 | assign k v = k <> "=" <> v 65 | 66 | sameSiteSer ∷ SameSite → String 67 | sameSiteSer Strict = "Strict" 68 | 69 | sameSiteSer Lax = "Lax" 70 | 71 | parseCookies ∷ String → Either String RequestCookies 72 | parseCookies s = 73 | splitPairs s 74 | <#> map toCookieMap 75 | <#> Object.fromFoldableWith append 76 | 77 | splitPairs ∷ String → Either String (Array (Tuple Name String)) 78 | splitPairs = 79 | split (Pattern ";") 80 | >>> map trim 81 | >>> filter ((/=) "") 82 | >>> map (split (Pattern "=") >>> toPair) 83 | >>> sequence 84 | 85 | toPair ∷ Array String → Either String (Tuple Name String) 86 | toPair kv = case kv of 87 | [ key, value ] → pure $ Tuple (unsafeDecodeURIComponent key) (unsafeDecodeURIComponent value) 88 | parts → throwError ("Invalid cookie-pair: " <> joinWith " " parts) 89 | 90 | toCookieMap ∷ Tuple Name String → Tuple Name Values 91 | toCookieMap (Tuple name value) = Tuple name (Array.NonEmpty.singleton value) 92 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Cookies/Types.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Cookies.Types where 2 | 3 | import Data.Array.NonEmpty (NonEmptyArray) 4 | import Data.JSDate (JSDate) 5 | import Data.Map (Map) 6 | import Data.Maybe (Maybe(..)) 7 | import Data.Newtype (class Newtype) 8 | import Data.Time.Duration (Seconds) 9 | import Foreign.Object (Object) 10 | 11 | type Name 12 | = String 13 | 14 | type Value 15 | = String 16 | 17 | type Values 18 | = NonEmptyArray Value 19 | 20 | type ResponseCookie 21 | = { value ∷ Value 22 | , attributes ∷ Attributes 23 | } 24 | 25 | type SetValue 26 | = ResponseCookie 27 | 28 | type RequestCookies 29 | = Object Values 30 | 31 | type ResponseCookies 32 | = Map Name ResponseCookie 33 | 34 | data SameSite 35 | = Strict 36 | | Lax 37 | 38 | type AttributesRecord 39 | = { comment ∷ Maybe String 40 | , domain ∷ Maybe String 41 | , expires ∷ Maybe JSDate 42 | , httpOnly ∷ Boolean 43 | , maxAge ∷ Maybe Seconds 44 | , path ∷ Maybe String 45 | , sameSite ∷ Maybe SameSite 46 | , secure ∷ Boolean 47 | } 48 | 49 | newtype Attributes 50 | = Attributes AttributesRecord 51 | 52 | derive instance newtypeAttributes ∷ Newtype Attributes _ 53 | 54 | defaultAttributes ∷ Attributes 55 | defaultAttributes = 56 | Attributes 57 | { comment: Nothing 58 | , domain: Nothing 59 | , expires: Nothing 60 | , httpOnly: false 61 | , maxAge: Nothing 62 | , path: Just "/" 63 | , sameSite: Nothing 64 | , secure: false 65 | } 66 | 67 | attributes ∷ (AttributesRecord → AttributesRecord) → Attributes 68 | attributes f = 69 | let 70 | Attributes r = defaultAttributes 71 | in 72 | Attributes (f r) 73 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/MediaTypes.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.MediaTypes 2 | ( known 3 | , module MediaType 4 | , imageSvg 5 | , parse 6 | ) 7 | where 8 | 9 | import Data.Array (elem) as Array 10 | import Data.Maybe (Maybe(..)) 11 | import Data.MediaType (MediaType(..)) 12 | import Data.MediaType.Common as Common 13 | import Data.MediaType.Common (applicationFormURLEncoded, applicationJSON, applicationJavascript, applicationOctetStream, applicationXML, imageGIF, imageJPEG, imagePNG, multipartFormData, textCSV, textHTML, textPlain, textXML, textCSS) as MediaType 14 | 15 | imageSvg ∷ MediaType 16 | imageSvg = MediaType "image/svg+xml" 17 | 18 | known ∷ Array MediaType 19 | known = 20 | [ Common.applicationFormURLEncoded 21 | , Common.applicationJSON 22 | , Common.applicationJavascript 23 | , Common.applicationOctetStream 24 | , Common.applicationXML 25 | , Common.imageGIF 26 | , Common.imageJPEG 27 | , Common.imagePNG 28 | , imageSvg 29 | , Common.multipartFormData 30 | , Common.textCSV 31 | , Common.textHTML 32 | , Common.textPlain 33 | , Common.textXML 34 | , Common.textCSS 35 | ] 36 | 37 | parse ∷ String → Maybe MediaType 38 | parse name = 39 | let 40 | possible = MediaType name 41 | in if possible `Array.elem` known 42 | then Just possible 43 | else Nothing 44 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Request.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Request 2 | ( module Headers 3 | , module Request 4 | ) 5 | where 6 | 7 | import WebRow.HTTP.Request.Headers (accept, accepts, header, headers, MediaPattern(..)) as Headers 8 | import WebRow.HTTP.Request.Request (body, fullPath, method, query, _request, runRequest, Request, REQUEST) as Request 9 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Request/Headers.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Request.Headers 2 | ( accept 3 | , accepts 4 | , headers 5 | , header 6 | , MediaPattern(..) 7 | ) 8 | where 9 | 10 | import Prelude 11 | 12 | import Data.Array (elem, fromFoldable) as Array 13 | import Data.Maybe (Maybe(..)) 14 | import Data.MediaType (MediaType) 15 | import Data.String (Pattern(..), split) as String 16 | import HTTPure (Headers, lookup) as HTTPure 17 | import Run (Run) 18 | import Run.Reader (askAt) 19 | import Type.Row (type (+)) 20 | import WebRow.HTTP.MediaTypes (parse) as MediaTypes 21 | import WebRow.HTTP.Request.Request (REQUEST, _request) 22 | 23 | headers ∷ ∀ eff. Run (REQUEST + eff) HTTPure.Headers 24 | headers = _.headers <$> askAt _request 25 | 26 | header ∷ ∀ eff. String → Run (REQUEST + eff) (Maybe String) 27 | header name = flip HTTPure.lookup name <$> headers 28 | 29 | data MediaPattern 30 | = ProperMediaType MediaType 31 | -- | */* 32 | | AnyMedia 33 | -- | image/* 34 | | AnyImage 35 | -- | video/* 36 | | AnyVideo 37 | | UnkonwnMediaPattern String 38 | derive instance eqMediaPattern ∷ Eq MediaPattern 39 | 40 | -- | TODO: Parse also quality factor like q=0.8 41 | -- | https://developer.mozilla.org/en-US/docs/Web/HTTP/Content_negotiation/List_of_default_Accept_values 42 | accept ∷ ∀ eff. Run (REQUEST + eff) (Array { pattern ∷ MediaPattern, q ∷ Maybe String }) 43 | accept = do 44 | parse <$> header "Accept" 45 | where 46 | parse mh = do 47 | h ← Array.fromFoldable mh 48 | v ← String.split (String.Pattern ",") h 49 | case String.split (String.Pattern ";") v of 50 | [ m ] → [{ pattern: mediaPattern m, q: Nothing }] 51 | [ m, q ] → [{ pattern: mediaPattern m, q: Just q }] 52 | otherwise → [] 53 | 54 | mediaPattern "*/*" = AnyMedia 55 | mediaPattern "image/*" = AnyImage 56 | mediaPattern "video/*" = AnyVideo 57 | mediaPattern p = case MediaTypes.parse p of 58 | Just mt → ProperMediaType mt 59 | Nothing → UnkonwnMediaPattern p 60 | 61 | -- | TODO: POSSIBLY A BUGGY STUB! We should check for patterns like img/* etc. probably 62 | accepts ∷ ∀ eff. MediaPattern → Run (REQUEST + eff) Boolean 63 | accepts pattern = do 64 | patterns ← accept 65 | pure $ pattern `Array.elem` map _.pattern patterns 66 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Request/Request.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Request.Request where 2 | 3 | import Prelude 4 | 5 | import Data.Array (last) as Array 6 | import Data.Maybe (fromMaybe) 7 | import Data.String (Pattern(..), split) as String 8 | import HTTPure.Method (Method) as HTTPure 9 | import HTTPure.Request (Request) as HTTPure 10 | import Polyform.Batteries.UrlEncoded (Query) 11 | import Polyform.Batteries.UrlEncoded.Query (parse) as Query 12 | import Run (Run) 13 | import Run.Reader (Reader, askAt, runReaderAt) 14 | import Type.Prelude (Proxy(..)) 15 | import Type.Row (type (+)) 16 | 17 | type Request = Reader HTTPure.Request 18 | 19 | type REQUEST r = ( request ∷ Request | r ) 20 | 21 | _request = Proxy ∷ Proxy "request" 22 | 23 | fullPath ∷ ∀ eff. Run (REQUEST + eff) String 24 | fullPath = _.url <$> askAt _request 25 | 26 | body ∷ ∀ eff. Run (REQUEST + eff) String 27 | body = _.body <$> askAt _request 28 | 29 | method ∷ ∀ eff. Run (REQUEST + eff) HTTPure.Method 30 | method = _.method <$> askAt _request 31 | 32 | query ∷ ∀ eff. Run (REQUEST + eff) Query 33 | query = parse <$> fullPath 34 | where 35 | split = String.Pattern >>> String.split 36 | 37 | parse 38 | = fromMaybe mempty 39 | <<< 40 | ( Query.parse { replacePlus: true } 41 | <=< Array.last 42 | <<< split "?" 43 | ) 44 | 45 | runRequest ∷ 46 | ∀ a eff. 47 | HTTPure.Request → 48 | Run (REQUEST + eff) a → 49 | Run eff a 50 | runRequest r = runReaderAt _request r 51 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Response.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Response 2 | ( module Exports 3 | , found 4 | , ok 5 | , okWithHeaders 6 | , run 7 | ) where 8 | 9 | import Prelude 10 | import HTTPure (Headers) 11 | import HTTPure (Response, header) as HTTPure 12 | import HTTPure (empty) as HTTPure.Headers 13 | import HTTPure.Body (write) as Body 14 | import HTTPure.Status (found, ok) as HTTPure.Status 15 | import Run (Run) 16 | import Run.Except (catchAt) 17 | import Type.Row (type (+)) 18 | import WebRow.HTTP.Response.BodyWriter (BodyWriter(..)) as Exports 19 | import WebRow.HTTP.Response.BodyWriter (BodyWriter(..)) as BodyWriter 20 | import WebRow.HTTP.Response.Except (_httpExcept, HTTPException(..), HTTPEXCEPT) 21 | import WebRow.HTTP.Response.Except (_httpExcept, HTTPException(..), HTTPEXCEPT, HTTPExcept(..), notFound) as Exports 22 | import WebRow.HTTP.Response.Headers (runSetHeader, SETHEADER, SetHeader) 23 | import WebRow.HTTP.Response.Headers (runSetHeader, setHeader, _setHeader, SETHEADER, SetHeader(..)) as Exports 24 | import WebRow.HTTP.Response.Types (Body(..), HTTPResponse(..), Parts) 25 | import WebRow.HTTP.Response.Types (ContentDisposition(..), HTTPResponse(..), Parts) as Exports 26 | import WebRow.Routing.Types (Url(..)) 27 | 28 | run ∷ 29 | ∀ eff. 30 | Run (SETHEADER + HTTPEXCEPT + eff) HTTPResponse → 31 | Run eff HTTPure.Response 32 | run action = action' 33 | where 34 | action' = runHTTPExcept <<< map fromResponse <<< runSetHeader $ action 35 | 36 | runHTTPExcept = catchAt _httpExcept (fromException >>> pure) 37 | 38 | fromResponse (HTTPResponse parts) = fromParts parts 39 | 40 | fromException (HTTPException parts) = fromParts parts 41 | 42 | fromParts ∷ Parts → HTTPure.Response 43 | fromParts { body, headers, status } = 44 | { status 45 | , headers 46 | , writeBody: 47 | case body of 48 | BodyString string → Body.write string 49 | BodyBuffer buffer → Body.write buffer 50 | BodyStream stream → Body.write stream 51 | BodyWriter writer → Body.write $ BodyWriter.BodyWriter writer 52 | } 53 | 54 | ok ∷ ∀ eff. String → Run eff HTTPResponse 55 | ok body = 56 | pure 57 | $ HTTPResponse { body: BodyString body, headers: HTTPure.Headers.empty, status: HTTPure.Status.ok } 58 | 59 | okWithHeaders ∷ ∀ eff. Headers → String → Run eff HTTPResponse 60 | okWithHeaders headers body = 61 | pure 62 | $ HTTPResponse { body: BodyString body, headers, status: HTTPure.Status.ok } 63 | 64 | found ∷ ∀ eff. Url → Run eff HTTPResponse 65 | found (Url location) = 66 | pure 67 | $ HTTPResponse { body: BodyString "", headers: HTTPure.header "location" location, status: HTTPure.Status.found } 68 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Response/BodyWriter.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Response.BodyWriter where 2 | 3 | import Prelude 4 | 5 | import Data.Either (Either) 6 | import Effect (Effect) 7 | import Effect.Aff (Error) as Effect.Exceptions 8 | import Effect.Aff (makeAff, nonCanceler) as Aff 9 | import HTTPure.Body (class Body) 10 | import HTTPure.Headers (header) as Headers 11 | import Node.HTTP (responseAsStream) as HTTP 12 | import Node.Stream (Writable) as Stream 13 | 14 | type Done a = Either Effect.Exceptions.Error a → Effect Unit 15 | 16 | type WriterContext = { done ∷ Done Unit, output ∷ Stream.Writable () } 17 | 18 | type WriteHandler = (WriterContext → Effect Unit) 19 | 20 | newtype BodyWriter = BodyWriter WriteHandler 21 | 22 | instance bodyChunkedWriter ∷ Body BodyWriter where 23 | 24 | -- | defaultHeaders :: b -> Effect.Effect Headers.Headers 25 | defaultHeaders _ = pure $ Headers.header "Transfer-Encoding" "chunked" 26 | 27 | -- | write :: b -> HTTP.Response -> Aff.Aff Unit 28 | write (BodyWriter writer) response = Aff.makeAff \done -> do 29 | -- let stream = TypeEquals.to body 30 | let 31 | output = HTTP.responseAsStream response 32 | -- Stream.onEnd stream $ done $ Either.Right unit 33 | _ <- writer { done, output } 34 | pure Aff.nonCanceler 35 | 36 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Response/Except.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Response.Except where 2 | 3 | import Prelude 4 | 5 | import HTTPure (Headers, header) as HTTPure 6 | import HTTPure.Headers (empty) as HTTPure.Headers 7 | import HTTPure.Headers (empty) as Headers 8 | import HTTPure.Status (badGateway, badRequest, forbidden, internalServerError, methodNotAllowed, notFound, notImplemented, serviceUnavailable, temporaryRedirect, unauthorized) as Status 9 | import Run (Run) 10 | import Run.Except (Except, EXCEPT, throwAt) 11 | import Type.Prelude (Proxy(..)) 12 | import Type.Row (type (+)) 13 | import WebRow.HTTP.Response.Types (Body(..), Parts) 14 | import WebRow.Routing.Types (Url(..)) 15 | 16 | -- | TODO: We want to probably carry json payload 17 | -- | which can be passed to services like: 18 | -- | * sentry 19 | -- | * console 20 | -- | * systemd? 21 | newtype HTTPException 22 | = HTTPException Parts 23 | 24 | _httpExcept = Proxy ∷ Proxy "httpExcept" 25 | 26 | type HTTPExcept = Except HTTPException 27 | 28 | type HTTPEXCEPT r = ( httpExcept ∷ HTTPExcept | r ) 29 | 30 | httpExcept ∷ ∀ a eff. HTTPException → Run ( HTTPEXCEPT + eff ) a 31 | httpExcept = throwAt _httpExcept 32 | 33 | redirect ∷ ∀ a eff. Url → Run ( HTTPEXCEPT + eff ) a 34 | redirect (Url url) = 35 | httpExcept 36 | $ HTTPException 37 | { body: BodyString "", headers: HTTPure.header "Location" url, status: Status.temporaryRedirect } 38 | 39 | badRequest ∷ ∀ a eff. HTTPure.Headers → Body → Run (HTTPEXCEPT + eff ) a 40 | badRequest headers body = httpExcept (HTTPException { body, headers, status: Status.badRequest }) 41 | 42 | badRequest' ∷ ∀ a eff. Body → Run ( HTTPEXCEPT + eff ) a 43 | badRequest' = badRequest HTTPure.Headers.empty 44 | 45 | badRequest'' ∷ ∀ a eff. Run ( HTTPEXCEPT + eff ) a 46 | badRequest'' = badRequest HTTPure.Headers.empty (BodyString "") 47 | 48 | unauthorized ∷ ∀ a eff. HTTPure.Headers → Run ( HTTPEXCEPT + eff ) a 49 | unauthorized headers = httpExcept (HTTPException { body: BodyString "", headers, status: Status.unauthorized }) 50 | 51 | forbidden ∷ ∀ a eff. HTTPure.Headers → Run ( HTTPEXCEPT + eff ) a 52 | forbidden headers = httpExcept (HTTPException { body: BodyString "", headers, status: Status.forbidden }) 53 | 54 | notFound ∷ ∀ a eff. HTTPure.Headers → Body → Run ( HTTPEXCEPT + eff ) a 55 | notFound headers body = httpExcept (HTTPException { body, headers, status: Status.notFound }) 56 | 57 | methodNotAllowed ∷ ∀ a eff. HTTPure.Headers → Run ( HTTPEXCEPT + eff ) a 58 | methodNotAllowed headers = httpExcept (HTTPException { body: BodyString "", headers, status: Status.methodNotAllowed }) 59 | 60 | methodNotAllowed' ∷ ∀ a eff. Run ( HTTPEXCEPT + eff ) a 61 | methodNotAllowed' = methodNotAllowed Headers.empty 62 | 63 | internalServerError ∷ ∀ a eff. HTTPure.Headers → Body → Run ( HTTPEXCEPT + eff ) a 64 | internalServerError headers body = httpExcept (HTTPException { body, headers, status: Status.internalServerError }) 65 | 66 | internalServerError' ∷ ∀ a eff. Body → Run ( HTTPEXCEPT + eff ) a 67 | internalServerError' = internalServerError Headers.empty 68 | 69 | notImplemented ∷ ∀ a eff. HTTPure.Headers → Run ( HTTPEXCEPT + eff ) a 70 | notImplemented headers = httpExcept (HTTPException { body: BodyString "", headers, status: Status.notImplemented }) 71 | 72 | badGateway ∷ ∀ a eff. HTTPure.Headers → Run ( HTTPEXCEPT + eff ) a 73 | badGateway headers = httpExcept (HTTPException { body: BodyString "", headers, status: Status.badGateway }) 74 | 75 | serviceUnavailable ∷ ∀ a eff. HTTPure.Headers → Run ( HTTPEXCEPT + eff ) a 76 | serviceUnavailable headers = httpExcept (HTTPException { body: BodyString "", headers, status: Status.serviceUnavailable }) 77 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Response/Headers.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Response.Headers where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe(..)) 6 | import Data.MediaType (MediaType(..)) 7 | import HTTPure (header) as HTTPure 8 | import Run (Run) 9 | import Run (lift, on, run, send) as Run 10 | import Type.Prelude (Proxy(..)) 11 | import Type.Row (type (+)) 12 | import WebRow.HTTP.Response.Except (HTTPException(..)) 13 | import WebRow.HTTP.Response.Types (ContentDisposition(..), HTTPResponse(..), Parts) 14 | 15 | -- | TODO: Change to `SETHEADERs (Tuple String String)` 16 | data SetHeader a 17 | = SetHeader String String a 18 | 19 | derive instance functorModifyF ∷ Functor SetHeader 20 | 21 | type SETHEADER r 22 | = ( setHeader ∷ SetHeader | r ) 23 | 24 | _setHeader = Proxy ∷ Proxy "setHeader" 25 | 26 | setHeader ∷ 27 | ∀ eff. 28 | String → 29 | String → 30 | Run ( SETHEADER + eff ) Unit 31 | setHeader k v = Run.lift _setHeader (SetHeader k v unit) 32 | 33 | setContentType ∷ ∀ eff. MediaType → Run (SETHEADER + eff) Unit 34 | setContentType (MediaType t) = 35 | setHeader "Content-Type" t 36 | 37 | setContentDisposition ∷ ∀ eff. ContentDisposition → Run (SETHEADER + eff) Unit 38 | setContentDisposition = case _ of 39 | Inline → setHeader header "inline" 40 | Attachment Nothing → setHeader header "attachment" 41 | Attachment (Just name) → 42 | setHeader header $ "attachment; filename=" <> name 43 | where 44 | header = "Content-Disposition" 45 | 46 | setHeaderOnParts ∷ String → String → Parts → Parts 47 | setHeaderOnParts k v parts = parts { headers = HTTPure.header k v <> parts.headers } 48 | 49 | setHeaderOnHTTPException ∷ String → String → HTTPException → HTTPException 50 | setHeaderOnHTTPException k v (HTTPException parts) = HTTPException $ setHeaderOnParts k v parts 51 | 52 | setHeaderOnHTTPResponse ∷ String → String → HTTPResponse → HTTPResponse 53 | setHeaderOnHTTPResponse k v (HTTPResponse parts) = HTTPResponse $ setHeaderOnParts k v parts 54 | 55 | runSetHeader ∷ 56 | ∀ eff. 57 | Run (SETHEADER + eff) HTTPResponse → 58 | Run (eff) HTTPResponse 59 | runSetHeader = 60 | Run.run 61 | $ Run.on _setHeader setOnResponse Run.send 62 | where 63 | setOnResponse (SetHeader k v a) = pure $ setHeaderOnHTTPResponse k v <$> a 64 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Response/Types.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Response.Types where 2 | 3 | import Prelude 4 | import Data.Either (Either) 5 | import Data.Generic.Rep (class Generic) 6 | import Data.Show.Generic (genericShow) 7 | import Data.Maybe (Maybe) 8 | import Data.Newtype (class Newtype) 9 | import Effect (Effect) 10 | import Effect.Exception (Error) as Effect.Exceptions 11 | import HTTPure (Headers, Status) as HTTPure 12 | import Node.Buffer (Buffer) 13 | import Node.Stream (Readable) as Stream 14 | import WebRow.HTTP.Response.BodyWriter (WriteHandler) as BodyWriter 15 | 16 | type Done a 17 | = Either Effect.Exceptions.Error a → Effect Unit 18 | 19 | data Body 20 | = BodyStream (Stream.Readable ()) 21 | | BodyBuffer Buffer 22 | | BodyString String 23 | | BodyWriter BodyWriter.WriteHandler 24 | 25 | type Parts 26 | = { body ∷ Body, headers ∷ HTTPure.Headers, status ∷ HTTPure.Status } 27 | 28 | -- | A tiny wrapper around response which enables 29 | -- | inspection during testing. 30 | newtype HTTPResponse 31 | = HTTPResponse Parts 32 | 33 | derive instance newtypeHTTPResponse ∷ Newtype HTTPResponse _ 34 | 35 | data ContentDisposition 36 | = Inline 37 | | Attachment (Maybe String) 38 | 39 | derive instance eqContentDisposition ∷ Eq ContentDisposition 40 | 41 | derive instance ordContentDisposition ∷ Ord ContentDisposition 42 | 43 | derive instance genericContentDisposition ∷ Generic ContentDisposition _ 44 | 45 | instance showContentDisposition ∷ Show ContentDisposition where 46 | show cd = genericShow cd 47 | -------------------------------------------------------------------------------- /src/WebRow/HTTP/Types.purs: -------------------------------------------------------------------------------- 1 | module WebRow.HTTP.Types where 2 | 3 | type Body 4 | = String 5 | -------------------------------------------------------------------------------- /src/WebRow/I18N.purs: -------------------------------------------------------------------------------- 1 | module WebRow.I18N 2 | ( module Routing 3 | , module TwoLetter 4 | ) where 5 | 6 | import WebRow.I18N.Routing (printRoute, printFullRoute, redirect, route, Routing', ROUTING', translatedRoute, translatedFullRoute) as Routing 7 | import WebRow.I18N.ISO639.TwoLetter (languageCode, getLanguage, LanguageCode, LanguageNames(..)) as TwoLetter 8 | -------------------------------------------------------------------------------- /src/WebRow/I18N/Routing.purs: -------------------------------------------------------------------------------- 1 | module WebRow.I18N.Routing where 2 | 3 | import Prelude hiding ((/)) 4 | 5 | import Control.Alt ((<|>)) 6 | import Data.Either (note) 7 | import Data.Newtype (un) 8 | import Data.Variant (class Contractable, Variant) 9 | import Routing.Duplex (RouteDuplex(..), RouteDuplex', as, segment) 10 | import Routing.Duplex (print) as D 11 | import Run (Run) 12 | import Run.Reader (askAt) 13 | import Type.Row (type (+)) 14 | import WebRow.HTTP (HTTPEXCEPT) 15 | import WebRow.HTTP (redirect) as HTTP.Response 16 | import WebRow.I18N.ISO639.TwoLetter (Languages, languageCode, parse, toString) 17 | import WebRow.Routing (FullUrl(..), ROUTING, RelativeUrl(..), _routing, fromRelativeUrl) 18 | import WebRow.Routing (Routing, printFullRoute, printRoute) as Routing 19 | 20 | type Route' langs route 21 | = { language ∷ Variant langs, route ∷ route } 22 | 23 | duplex ∷ 24 | ∀ langs route. 25 | Contractable Languages langs ⇒ 26 | Variant langs → 27 | RouteDuplex' route → 28 | RouteDuplex' (Route' langs route) 29 | duplex default (RouteDuplex routePrinter routeParser) = RouteDuplex printer parser 30 | where 31 | RouteDuplex langPrinter langParser = (as (languageCode >>> toString) (parse >>> note "Invalid language code")) segment 32 | 33 | printer { language: l, route: r } = 34 | if languageCode l == languageCode default then 35 | routePrinter r 36 | else 37 | langPrinter l <> routePrinter r 38 | 39 | parser = 40 | ({ language: _, route: _ } <$> langParser <*> routeParser) 41 | <|> ({ language: default, route: _ } <$> routeParser) 42 | 43 | type Routing' langs routes eff 44 | = Routing.Routing (Route' langs routes) eff 45 | 46 | type ROUTING' (langs ∷ Row Type) route eff 47 | = ROUTING (Route' langs route) eff 48 | 49 | printRoute ∷ ∀ eff langs route. route → Run ( ROUTING' langs route + eff ) RelativeUrl 50 | printRoute v = 51 | map RelativeUrl 52 | $ do 53 | routing ← askAt _routing 54 | pure $ D.print routing.routeDuplex { language: routing.route.language, route: v } 55 | 56 | printFullRoute ∷ ∀ eff langs route. route → Run ( ROUTING' langs route + eff ) FullUrl 57 | printFullRoute v = map FullUrl $ (<>) <$> (askAt _routing <#> _.domain) <*> (map (un RelativeUrl) $ printRoute v) 58 | 59 | translatedRoute ∷ ∀ eff langs route. Variant langs → route → Run ( ROUTING' langs route + eff ) RelativeUrl 60 | translatedRoute lang v = Routing.printRoute { language: lang, route: v } 61 | 62 | translatedFullRoute ∷ ∀ eff langs route. Variant langs → route → Run ( ROUTING' langs route + eff ) FullUrl 63 | translatedFullRoute lang v = Routing.printFullRoute { language: lang, route: v } 64 | 65 | fullRoute ∷ ∀ eff langs route. Run (ROUTING' langs route + eff) (Route' langs route) 66 | fullRoute = _.route <$> askAt _routing 67 | 68 | route ∷ ∀ eff langs route. Run (ROUTING' langs route + eff) route 69 | route = _.route <<< _.route <$> askAt _routing 70 | 71 | language ∷ ∀ eff langs route. Run (ROUTING' langs route + eff) (Variant langs) 72 | language = _.language <<< _.route <$> askAt _routing 73 | 74 | redirect ∷ 75 | ∀ a eff langs route. 76 | route → 77 | Run 78 | ( HTTPEXCEPT 79 | + ROUTING' langs route 80 | + eff 81 | ) 82 | a 83 | redirect r = do 84 | url ← printRoute r 85 | HTTP.Response.redirect (fromRelativeUrl url) 86 | -------------------------------------------------------------------------------- /src/WebRow/Logger.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Logger 2 | ( debug 3 | , err 4 | , info 5 | , LOGGER 6 | , LOGGER 7 | , runToConsole 8 | , warning 9 | , Logger(..) 10 | , module Level 11 | ) where 12 | 13 | import Prelude 14 | 15 | import Data.Symbol (SProxy(..)) 16 | import Effect.Class.Console as Console 17 | import Run (Run, AFF) 18 | import Run as Run 19 | import Type.Prelude (Proxy(..)) 20 | import Type.Row (type (+)) 21 | import WebRow.Logger.Level (Level(..)) 22 | import WebRow.Logger.Level (Level(..)) as Level 23 | 24 | data Logger a = Logger Level String a 25 | 26 | derive instance functorLogger ∷ Functor Logger 27 | 28 | type LOGGER r = (logger ∷ Logger | r) 29 | 30 | _logger = SProxy ∷ SProxy "logger" 31 | 32 | log ∷ ∀ eff. Level → String → Run ( LOGGER + eff ) Unit 33 | log lvl msg = Run.lift _logger (Logger lvl msg unit) 34 | 35 | debug ∷ ∀ eff. String → Run ( LOGGER + eff ) Unit 36 | debug = log Debug 37 | 38 | info ∷ ∀ eff. String → Run ( LOGGER + eff ) Unit 39 | info = log Info 40 | 41 | warning ∷ ∀ eff. String → Run ( LOGGER + eff ) Unit 42 | warning = log Warning 43 | 44 | err ∷ ∀ eff. String → Run ( LOGGER + eff ) Unit 45 | err = log Err 46 | 47 | runToConsole ∷ 48 | ∀ a eff. 49 | Run ( AFF + LOGGER + eff ) a → 50 | Run ( AFF + eff ) a 51 | runToConsole = Run.interpret (Run.on _logger handleLoggerConsole Run.send) 52 | where 53 | handleLoggerConsole ∷ 54 | ∀ b. 55 | Logger b → 56 | Run ( AFF + eff ) b 57 | handleLoggerConsole (Logger lvl msg next) = do 58 | Run.liftAff $ Console.log $ (show lvl) <> ":> " <> show msg 59 | pure next 60 | -------------------------------------------------------------------------------- /src/WebRow/Logger/Level.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Logger.Level where 2 | 3 | import Prelude 4 | import Data.Generic.Rep (class Generic) 5 | import Data.Show.Generic (genericShow) 6 | import Data.Maybe (Maybe(..)) 7 | 8 | -- | TODO: extract purescript-logging-level 9 | -- | because these names are taken from journald lib. 10 | data Level 11 | = Debug 12 | | Info 13 | | Notice 14 | | Warning 15 | | Err 16 | | Crit 17 | | Alert 18 | | Emerg 19 | 20 | derive instance genericLevel ∷ Generic Level _ 21 | 22 | derive instance ordLevel ∷ Ord Level 23 | 24 | derive instance eqLevel ∷ Eq Level 25 | 26 | instance showLevel ∷ Show Level where 27 | show = genericShow 28 | 29 | fromString ∷ String → Maybe Level 30 | fromString "DEBUG" = Just Debug 31 | 32 | fromString "INFO" = Just Info 33 | 34 | fromString "NOTICE" = Just Notice 35 | 36 | fromString "WARNING" = Just Warning 37 | 38 | fromString "ERR" = Just Err 39 | 40 | fromString "CRIT" = Just Crit 41 | 42 | fromString "ALERT" = Just Alert 43 | 44 | fromString "EMERG" = Just Emerg 45 | 46 | fromString _ = Nothing 47 | -------------------------------------------------------------------------------- /src/WebRow/Mailer.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Mailer where 2 | 3 | import Prelude 4 | import Data.Maybe (Maybe(..)) 5 | import Data.Newtype (class Newtype) 6 | import Data.String (Pattern(..), contains) as String 7 | import Data.Variant (Variant) 8 | import Run (Run) 9 | import Run as Run 10 | import Type.Row (type (+)) 11 | import Type.Prelude (Proxy(..)) 12 | 13 | newtype Email 14 | = Email String 15 | 16 | derive instance newtypeEmail ∷ Newtype Email _ 17 | 18 | derive instance eqEmail ∷ Eq Email 19 | 20 | derive instance ordEmail ∷ Ord Email 21 | 22 | derive newtype instance showEmail ∷ Show Email 23 | 24 | -- | TODO: Fix this smart constructor - possibly use this: 25 | -- | https://github.com/cdepillabout/purescript-email-validate 26 | email ∷ String → Maybe Email 27 | email e = 28 | if String.contains (String.Pattern "@") e then 29 | Just (Email e) 30 | else 31 | Nothing 32 | 33 | type Mail mail 34 | = { to ∷ Email, context ∷ Variant mail } 35 | 36 | data Mailer mails a = Send (Mail mails) a 37 | 38 | derive instance functorMailerF ∷ Functor (Mailer mails) 39 | 40 | type MAILER mails eff 41 | = ( mailer ∷ Mailer mails | eff ) 42 | 43 | _mailer = Proxy ∷ Proxy "mailer" 44 | 45 | send ∷ 46 | ∀ eff mails. 47 | Mail mails → 48 | Run (MAILER mails + eff) Unit 49 | send mail = Run.lift _mailer (Send mail unit) 50 | -------------------------------------------------------------------------------- /src/WebRow/Message.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Message where 2 | 3 | import Prelude 4 | 5 | import Run (Run) 6 | import Run as Run 7 | import Type.Row (type (+)) 8 | import Type.Prelude (Proxy(..)) 9 | 10 | data Message msg a 11 | = Message msg (String → a) 12 | 13 | derive instance Functor (Message info) 14 | 15 | _message = Proxy ∷ Proxy "message" 16 | 17 | type MESSAGE messages eff 18 | = ( message ∷ Message messages | eff ) 19 | 20 | message ∷ 21 | ∀ eff msg. 22 | msg → 23 | Run (MESSAGE msg + eff) String 24 | message msg = Run.lift _message (Message msg identity) 25 | 26 | run ∷ ∀ a eff msg. (msg → String) → Run (MESSAGE msg + eff) a -> Run eff a 27 | run print = Run.interpret (Run.on _message handleMessage Run.send) 28 | where 29 | handleMessage ∷ ∀ m. Monad m ⇒ Message msg ~> m 30 | handleMessage (Message v next) = pure $ next (print v) 31 | 32 | -------------------------------------------------------------------------------- /src/WebRow/PostgreSQL.purs: -------------------------------------------------------------------------------- 1 | module WebRow.PostgreSQL 2 | ( module PG 3 | , module PostgreSQL 4 | ) 5 | where 6 | 7 | import WebRow.PostgreSQL.PG (Inside, _pgExcept, PGEXCEPT, _pg, PG, Pg, Outside, run, kind TransactionMode, withTransaction) as PG 8 | import Database.PostgreSQL (Row0(..), Row1(..), Row2(..), Row3(..), Row4(..), Query(..)) as PostgreSQL 9 | 10 | 11 | -------------------------------------------------------------------------------- /src/WebRow/PostgreSQL/CLI.purs: -------------------------------------------------------------------------------- 1 | module WebRow.PostgreSQL.CLI where 2 | 3 | import Prelude 4 | import Control.Alt ((<|>)) 5 | import Data.Maybe (Maybe(..), optional) 6 | import Database.PostgreSQL (defaultConfiguration) 7 | import Database.PostgreSQL as PG 8 | import Effect (Effect) 9 | import Options.Applicative ((<**>)) 10 | import Options.Applicative as Optparse 11 | 12 | type Options 13 | = { database ∷ PG.Configuration 14 | -- , schema ∷ String 15 | -- , action ∷ Action 16 | } 17 | 18 | getOptions ∷ Effect Options 19 | getOptions = Optparse.execParser (Optparse.info (options <**> Optparse.helper) Optparse.fullDesc) 20 | 21 | options ∷ Optparse.Parser Options 22 | options = 23 | { database: _ 24 | -- , schema: _ 25 | -- , action: _ 26 | } 27 | <$> database 28 | -- <*> schema 29 | -- <*> action 30 | where 31 | database = pool <$> (db <|> pure default) 32 | where 33 | pool cfg = 34 | (defaultConfiguration cfg.name) 35 | { host = cfg.host 36 | , idleTimeoutMillis = cfg.idleTimeoutMillis 37 | , user = cfg.user 38 | , password = cfg.password 39 | , port = cfg.port 40 | } 41 | 42 | default = 43 | { host: Nothing 44 | , idleTimeoutMillis: Just 100 45 | , name: "streaming_stats" 46 | , password: Just "qwerty" 47 | , port: Nothing 48 | , user: Just "init" 49 | } 50 | 51 | db = 52 | { host: _, idleTimeoutMillis: _, name: _, password: _, port: _, user: _ } 53 | <$> optional host 54 | <*> (Just <$> idleTimeoutMillis <|> pure default.idleTimeoutMillis) 55 | <*> name 56 | <*> optional password 57 | <*> optional port 58 | <*> optional user 59 | 60 | host = 61 | Optparse.strOption 62 | $ Optparse.long "db-host" 63 | <> Optparse.metavar "DATABASE_HOST" 64 | <> Optparse.help "Database host" 65 | 66 | idleTimeoutMillis = 67 | (Optparse.option Optparse.int) 68 | $ Optparse.long "db-idle-timeout" 69 | <> Optparse.metavar "TIMOUT_IN_MILLISECONDS" 70 | <> Optparse.help "Database connection idle timeout. Useful when testing." 71 | 72 | name = 73 | Optparse.strOption 74 | $ Optparse.long "db-name" 75 | <> Optparse.metavar "DATABASE" 76 | <> Optparse.help "Database name" 77 | 78 | password = 79 | Optparse.strOption 80 | $ Optparse.long "db-password" 81 | <> Optparse.metavar "DATABASE_PASSWORD" 82 | <> Optparse.help "Database password" 83 | 84 | port = 85 | (Optparse.option Optparse.int) 86 | $ Optparse.long "db-port" 87 | <> Optparse.metavar "DATABASE_PORT" 88 | <> Optparse.help "Database port" 89 | 90 | user = 91 | Optparse.strOption 92 | $ Optparse.long "db-user" 93 | <> Optparse.metavar "DATABASE_USER" 94 | <> Optparse.help "Database user" 95 | 96 | schema = 97 | Optparse.strOption 98 | $ Optparse.long "db-schema" 99 | <> Optparse.short 's' 100 | <> Optparse.metavar "SCHEMA" 101 | <> Optparse.help "Database schema" 102 | -------------------------------------------------------------------------------- /src/WebRow/PostgreSQL/Internal.purs: -------------------------------------------------------------------------------- 1 | module WebRow.PostgreSQL.Internal where 2 | 3 | import Prelude 4 | import Control.Monad.Resource (Resource) as Resource 5 | import Data.Either (Either(..)) 6 | import Data.Maybe (Maybe(..)) 7 | import Data.Tuple.Nested ((/\), type (/\)) 8 | import Database.PostgreSQL (Connection, PGError, Pool, fromPool) as PG 9 | import Effect (Effect) 10 | import Effect.Aff (Aff) 11 | import Effect.Aff.Class (liftAff) as Aff.Class 12 | import Effect.Class (liftEffect) as Effect.Class 13 | import Run (Run) 14 | import Run as Run 15 | import Type.Row (type (+)) 16 | import Type.Prelude (Proxy(..)) 17 | 18 | -- | I'm not sure if it is possible to abstract away 19 | -- | whole pg interaction if I want to preserve 20 | -- | `withTransaction` (it seems that it should contain 21 | -- | `Run` value inside itself - is it possible?). 22 | -- | Because of this problem we provide only tiny a layer 23 | -- | above reader / Aff effect (to limit the damage). 24 | newtype Pg mode a 25 | = Pg (Conn mode → Resource.Resource (Either PG.PGError a)) 26 | 27 | derive instance pgFunctor ∷ Functor (Pg mode) 28 | 29 | -- | We prevent nesting transaction on the type level. 30 | foreign import kind TransactionMode 31 | 32 | foreign import data Inside ∷ TransactionMode 33 | 34 | foreign import data Outside ∷ TransactionMode 35 | 36 | _pg = Proxy ∷ Proxy "pg" 37 | 38 | type PG mode r 39 | = ( pg ∷ Pg mode | r ) 40 | 41 | -- | TODO: 42 | -- | This is somewhat unsafe meaning we can have 43 | -- | (mode ∷ Inside) but lack the connection value... 44 | -- | Should we really care about this incosistency? 45 | newtype Conn (mode ∷ TransactionMode) 46 | = Conn (PG.Pool /\ (Maybe PG.Connection)) 47 | 48 | connection ∷ ∀ mode r. Run (PG mode + r) PG.Connection 49 | connection = Run.lift _pg (Pg (pure <<< wrap)) 50 | where 51 | wrap (Conn (p /\ Nothing)) = Right (PG.fromPool p) 52 | 53 | wrap (Conn (_ /\ (Just conn))) = Right conn 54 | 55 | pool ∷ ∀ mode r. Run (PG mode + r) PG.Pool 56 | pool = Run.lift _pg (Pg (pure <<< wrap)) 57 | where 58 | wrap (Conn (p /\ _)) = Right p 59 | 60 | liftPgAff ∷ ∀ a mode r. Aff (Either PG.PGError a) → Run (PG mode + r) a 61 | liftPgAff action = Run.lift _pg (Pg $ const $ Aff.Class.liftAff action) 62 | 63 | liftAff ∷ ∀ a mode r. Aff a → Run (PG mode + r) a 64 | liftAff action = liftPgAff (map Right action) 65 | 66 | liftEffect ∷ ∀ a mode r. Effect a → Run (PG mode + r) a 67 | liftEffect action = liftAff $ Effect.Class.liftEffect action 68 | 69 | -------------------------------------------------------------------------------- /src/WebRow/PostgreSQL/PG.purs: -------------------------------------------------------------------------------- 1 | -- | This module: 2 | -- | * Exposes low level PostgreSql API (internally it is Reader + wrapping around Resource / Aff). 3 | -- | * Uses JS `Pool.query` as a default mode for quering DB. 4 | -- | * Provides a way for managing transaction in a safe manner. 5 | module WebRow.PostgreSQL.PG 6 | ( module Exports 7 | , command 8 | , execute 9 | , scalar 10 | , _pgExcept 11 | , PGEXCEPT 12 | , query 13 | , run 14 | , withTransaction 15 | ) 16 | where 17 | 18 | import Prelude 19 | 20 | import Control.Monad.Error.Class (catchError, throwError) 21 | import Control.Monad.Resource (acquire) as Resource 22 | import Data.Either (Either(..)) 23 | import Data.Maybe (Maybe(..)) 24 | import Data.Tuple (snd) 25 | import Data.Tuple.Nested ((/\)) 26 | import Database.PostgreSQL (class FromSQLRow, class FromSQLValue, class ToSQLRow, ConnectResult, PGError(..), Pool, Query(..), Row0(..), Row1, fromClient) as PG 27 | import Database.PostgreSQL.Aff (command, connect, execute, query, scalar) as PG 28 | import Effect.Aff (Aff) 29 | import Effect.Class (liftEffect) as Effect.Class 30 | import Effect.Exception (error) as Effect.Exception 31 | import Effect.Ref (Ref) 32 | import Effect.Ref (new, read, write) as Ref 33 | import Prim.Row (class Cons) as Row 34 | import Run (Run) 35 | import Run as Run 36 | import Run.Except (Except) 37 | import Run.Except (throwAt) as Run.Except 38 | import Type.Row (type (+)) 39 | import Type.Prelude (Proxy(..)) 40 | import Unsafe.Coerce (unsafeCoerce) 41 | import WebRow.PostgreSQL.Internal (Conn(..), Inside, Outside, PG, Pg(..), _pg, connection, liftEffect, liftPgAff, pool) 42 | import WebRow.PostgreSQL.Internal (Pg, PG, _pg, Inside, Outside, TransactionMode) as Exports 43 | import WebRow.Resource (RESOURCE, liftResource) 44 | 45 | execute :: 46 | ∀ i mode o r. 47 | PG.ToSQLRow i ⇒ 48 | PG.Query i o → 49 | i → 50 | Run (PG mode + r) Unit 51 | execute q i = do 52 | conn <- connection 53 | liftPgAff (map liftErr $ PG.execute conn q i) 54 | where 55 | liftErr Nothing = Right unit 56 | 57 | liftErr (Just err) = Left err 58 | 59 | query :: 60 | ∀ i mode o r. 61 | PG.ToSQLRow i => 62 | PG.FromSQLRow o => 63 | PG.Query i o -> 64 | i -> 65 | Run (PG mode + r) (Array o) 66 | query q i = do 67 | conn <- connection 68 | liftPgAff (PG.query conn q i) 69 | 70 | scalar :: 71 | forall i mode o r. 72 | PG.ToSQLRow i => 73 | PG.FromSQLValue o => 74 | PG.Query i (PG.Row1 o) -> 75 | i -> 76 | Run (PG mode + r) (Maybe o) 77 | scalar q i = do 78 | conn <- connection 79 | liftPgAff (PG.scalar conn q i) 80 | 81 | command :: 82 | forall i mode r. 83 | PG.ToSQLRow i => 84 | PG.Query i Int -> 85 | i -> 86 | Run (PG mode + r) Int 87 | command q i = do 88 | conn <- connection 89 | liftPgAff (PG.command conn q i) 90 | 91 | type Commited 92 | = Boolean 93 | 94 | rollback ∷ Ref Commited → Either PG.PGError PG.ConnectResult → Aff Unit 95 | rollback _ (Left _) = pure unit 96 | 97 | rollback ref (Right { client, done }) = do 98 | commited ← Effect.Class.liftEffect $ Ref.read ref 99 | when (not commited) 100 | $ do 101 | void 102 | $ (PG.execute (PG.fromClient client) (PG.Query "ROLLBACK TRANSACTION") PG.Row0) 103 | `catchError` 104 | (const $ pure Nothing) 105 | -- | I'm swallowing rollback exceptions 106 | -- | at the moment... Should I rethrow them? 107 | -- case err of 108 | -- Just e → rethrow e 109 | -- Nothing → pure unit 110 | pure unit 111 | Effect.Class.liftEffect done 112 | where 113 | rethrow ∷ PG.PGError → Aff Unit 114 | rethrow e = 115 | throwError 116 | $ case e of 117 | PG.ClientError err _ → err 118 | PG.ConversionError s → Effect.Exception.error s 119 | PG.InternalError err -> err.error 120 | PG.OperationalError err -> err.error 121 | PG.ProgrammingError err -> err.error 122 | PG.IntegrityError err -> err.error 123 | PG.DataError err -> err.error 124 | PG.NotSupportedError err -> err.error 125 | PG.QueryCanceledError err -> err.error 126 | PG.TransactionRollbackError err -> err.error 127 | 128 | withTransaction ∷ ∀ a r. Run (PG Inside + r) a → Run (PG Outside + r) a 129 | withTransaction action = do 130 | p ← pool 131 | ref ← liftEffect $ Ref.new false 132 | { client } ← Run.lift _pg (Pg $ const $ snd <$> (Resource.acquire (connect p) (rollback ref))) 133 | let 134 | conn = Conn (p /\ (Just $ PG.fromClient client)) 135 | 136 | -- | Run.expand definition is based on `Union` constraint 137 | -- | We want to use `Row.Cons` constraint here instead. 138 | expand' ∷ ∀ l b t t_. Row.Cons l b t_ t ⇒ Proxy l → Run t_ ~> Run t 139 | expand' _ = unsafeCoerce 140 | 141 | handle (Pg k) = Run.send $ Run.inj _pg $ Pg \_ → k conn 142 | a ← Run.run (Run.on _pg handle (Run.send >>> expand' _pg)) action 143 | liftPgAff $ map liftErr $ PG.execute (PG.fromClient client) (PG.Query "COMMIT TRANSACTION") PG.Row0 144 | void $ liftEffect $ Ref.write true ref 145 | pure a 146 | where 147 | liftErr Nothing = Right unit 148 | 149 | liftErr (Just err) = Left err 150 | 151 | connect p = do 152 | PG.connect p 153 | >>= case _ of 154 | err@(Left _) → pure err 155 | res@(Right { client }) → do 156 | PG.execute (PG.fromClient client) (PG.Query "BEGIN TRANSACTION") PG.Row0 157 | >>= case _ of 158 | Just err → pure (Left err) 159 | Nothing → pure res 160 | 161 | type PGEXCEPT r = ( pgExcept ∷ Except PG.PGError | r ) 162 | 163 | _pgExcept = Proxy ∷ Proxy "pgExcept" 164 | 165 | run ∷ ∀ a r. PG.Pool → Run (PG Outside + PGEXCEPT + RESOURCE + r) a → Run (PGEXCEPT + RESOURCE + r) a 166 | run p action = Run.run (Run.on _pg handle Run.send) action 167 | where 168 | handle (Pg k) = do 169 | let 170 | conn = Conn (p /\ Nothing) 171 | liftResource (k conn) 172 | >>= case _ of 173 | Right next → pure next 174 | Left err → Run.Except.throwAt _pgExcept err 175 | -------------------------------------------------------------------------------- /src/WebRow/PostgreSQL/Selda.purs: -------------------------------------------------------------------------------- 1 | module WebRow.PostgreSQL.Selda where 2 | 3 | import Prelude 4 | import Data.Maybe (Maybe) 5 | import Database.PostgreSQL (class FromSQLRow) 6 | import Run (Run) 7 | import Selda (Col, FullQuery, Table) 8 | import Selda.Col (class GetCols) 9 | import Selda.PG.Aff (PGSelda) 10 | import Selda.PG.Aff (deleteFrom, insert, insert1, insert1_, insert_, query, query1, update) as Selda.PG.Aff 11 | import Selda.PG.Class (class InsertRecordIntoTableReturning, BackendPGClass) 12 | import Selda.Query.Class (class GenericInsert) 13 | import Selda.Query.Utils (class ColsToPGHandler, class TableToColsWithoutAlias) 14 | import Type.Row (type (+)) 15 | import WebRow.PostgreSQL.Internal (connection, liftPgAff) 16 | import WebRow.PostgreSQL.PG (PG) 17 | 18 | query ∷ 19 | ∀ eff i mode o tup. 20 | ColsToPGHandler BackendPGClass i tup o ⇒ 21 | GetCols i ⇒ 22 | FromSQLRow tup ⇒ 23 | FullQuery BackendPGClass { | i } → 24 | Run (PG mode + eff) (Array { | o }) 25 | query q = do 26 | conn ← connection 27 | liftPgAff (Selda.PG.Aff.query conn q) 28 | 29 | query1 ∷ 30 | ∀ eff i o mode tup. 31 | ColsToPGHandler BackendPGClass i tup o ⇒ 32 | GetCols i ⇒ 33 | FromSQLRow tup ⇒ 34 | FullQuery BackendPGClass { | i } → 35 | Run (PG mode + eff) (Maybe { | o }) 36 | query1 q = do 37 | conn ← connection 38 | liftPgAff (Selda.PG.Aff.query1 conn q) 39 | 40 | insert ∷ 41 | ∀ eff mode r t ret. 42 | InsertRecordIntoTableReturning r t ret ⇒ 43 | Table t → Array { | r } → Run (PG mode + eff) (Array { | ret }) 44 | insert table xs = do 45 | conn ← connection 46 | liftPgAff $ Selda.PG.Aff.insert conn table xs 47 | 48 | insert_ ∷ 49 | ∀ eff mode r t. 50 | GenericInsert BackendPGClass PGSelda t r ⇒ 51 | Table t → Array { | r } → Run (PG mode + eff) Unit 52 | insert_ table xs = do 53 | conn ← connection 54 | liftPgAff $ Selda.PG.Aff.insert_ conn table xs 55 | 56 | insert1 ∷ 57 | ∀ eff mode r t ret. 58 | InsertRecordIntoTableReturning r t ret ⇒ 59 | Table t → { | r } → Run (PG mode + eff) { | ret } 60 | insert1 table xs = do 61 | conn ← connection 62 | liftPgAff $ Selda.PG.Aff.insert1 conn table xs 63 | 64 | insert1_ ∷ 65 | ∀ eff mode t r. 66 | GenericInsert BackendPGClass PGSelda t r ⇒ 67 | Table t → { | r } → Run (PG mode + eff) Unit 68 | insert1_ table r = do 69 | conn ← connection 70 | liftPgAff $ Selda.PG.Aff.insert1_ conn table r 71 | 72 | deleteFrom ∷ 73 | ∀ eff mode r r'. 74 | TableToColsWithoutAlias BackendPGClass r r' ⇒ 75 | Table r → 76 | ({ | r' } → Col BackendPGClass Boolean) → 77 | Run (PG mode + eff) Unit 78 | deleteFrom table r = do 79 | conn ← connection 80 | liftPgAff $ Selda.PG.Aff.deleteFrom conn table r 81 | 82 | update ∷ 83 | ∀ eff mode r r'. 84 | TableToColsWithoutAlias BackendPGClass r r' ⇒ 85 | GetCols r' ⇒ 86 | Table r → 87 | ({ | r' } → Col BackendPGClass Boolean) → 88 | ({ | r' } → { | r' }) → 89 | Run (PG mode + eff) Unit 90 | update table pred up = do 91 | conn ← connection 92 | liftPgAff $ Selda.PG.Aff.update conn table pred up 93 | -------------------------------------------------------------------------------- /src/WebRow/PostgreSQL/Types.purs: -------------------------------------------------------------------------------- 1 | module WebRow.PostgreSQL.Types where 2 | 3 | foreign import kind TransactionMode 4 | 5 | foreign import data Inside ∷ TransactionMode 6 | 7 | foreign import data Outside ∷ TransactionMode 8 | -------------------------------------------------------------------------------- /src/WebRow/Resource.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Resource where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Resource (Resource) 6 | import Control.Monad.Resource (runResource) 7 | import Control.Monad.Trans.Class (lift) as Trans.Class 8 | import Data.Functor.Variant (on) 9 | import Effect (Effect) 10 | import Effect.Aff (Aff) 11 | import Effect.Class (liftEffect) as Effect 12 | import Run (AFF, Run, EFFECT) 13 | import Run (lift, match, run, send) as Run 14 | import Type.Prelude (SProxy(..)) 15 | import Type.Row (type (+)) 16 | import WebRow.Contrib.Run (_aff, _effect) 17 | 18 | _resource = SProxy ∷ SProxy "resource" 19 | 20 | type RESOURCE r 21 | = ( resource ∷ Resource | r ) 22 | 23 | liftAff ∷ ∀ r. Aff ~> Run (RESOURCE + r) 24 | liftAff = Run.lift _resource <<< Trans.Class.lift 25 | 26 | liftResource ∷ ∀ r. Resource ~> Run (RESOURCE + r) 27 | liftResource = Run.lift _resource 28 | 29 | liftEffect ∷ ∀ r. Effect ~> Run (RESOURCE + r) 30 | liftEffect = Run.lift _resource <<< Effect.liftEffect 31 | 32 | liftBaseAff ∷ ∀ r. Run (AFF + EFFECT + RESOURCE + r) ~> Run (RESOURCE + r) 33 | liftBaseAff = Run.run handleBaseAff 34 | where 35 | handleBaseAff = 36 | Run.send 37 | # on _aff liftAff 38 | # on _effect (liftAff <<< Effect.liftEffect) 39 | 40 | run ∷ Run (RESOURCE + ()) ~> Aff 41 | run = runResource <<< Run.run (Run.match { resource: \a → a }) 42 | 43 | runBaseResource ∷ Run (RESOURCE + ()) ~> Aff 44 | runBaseResource r = runResource $ Run.run m r 45 | where 46 | m = Run.match { resource: \a → a } 47 | 48 | runBaseResource' ∷ Run (AFF + EFFECT + RESOURCE + ()) ~> Aff 49 | runBaseResource' r = runResource $ Run.run m r 50 | where 51 | m = 52 | Run.match 53 | { aff: \a → Trans.Class.lift a 54 | , effect: \a → Trans.Class.lift $ Effect.liftEffect a 55 | , resource: \a → a 56 | } 57 | -------------------------------------------------------------------------------- /src/WebRow/Routing.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Routing 2 | ( module Exports 3 | , Routing 4 | , ROUTING 5 | , ROUTING' 6 | , context 7 | , printRoute 8 | , printFullRoute 9 | , redirect 10 | , route 11 | , _routing 12 | , runRouting 13 | , toFullUrl 14 | , url 15 | ) where 16 | 17 | import Prelude 18 | 19 | import Data.Array (singleton) as Array 20 | import Data.Either (Either(..)) 21 | import Data.Lazy (defer) as L 22 | import Data.Map (fromFoldableWith) as Map 23 | import Data.String (Pattern(..), Replacement(..), replaceAll) as String 24 | import Data.Variant (Variant) 25 | import HTTPure.Headers (empty) as HTTPure.Headers 26 | import HTTPure.Request (Request) as HTTPure 27 | import Polyform.Batteries.UrlEncoded (Query(..)) 28 | import Routing.Duplex (RouteDuplex', print) as D 29 | import Routing.Duplex (RouteDuplex(..), RouteDuplex') 30 | import Routing.Duplex.Parser (RouteError, RouteResult(..), parsePath, runRouteParser) as D 31 | import Run (Run) 32 | import Run.Reader (Reader, askAt) 33 | import Type.Row (type (+)) 34 | import Type.Prelude (Proxy(..)) 35 | import WebRow.Contrib.Run.Reader (runReaders) 36 | import WebRow.HTTP (HTTPEXCEPT) 37 | import WebRow.HTTP (redirect) as HTTP.Response 38 | import WebRow.HTTP.Request (REQUEST) 39 | import WebRow.HTTP.Response.Except (notFound) 40 | import WebRow.HTTP.Response.Types (Body(..)) 41 | import WebRow.Routing.Types (Context, Domain, FullUrl(..), RelativeUrl(..), fromRelativeUrl) 42 | import WebRow.Routing.Types (Context, Domain, FullUrl(..), RelativeUrl(..), fromRelativeUrl, fromFullUrl) as Exports 43 | 44 | _routing = Proxy ∷ Proxy "routing" 45 | 46 | -- | TODO: 47 | -- | Do we want to use custom effect here like 48 | -- | 49 | -- | `data RoutingF = PrintRouteF .. | PrintFullRouteF ... | RedirectF ... 50 | -- | 51 | -- | Then we can abstract over i18n and simple routes in generic applets. 52 | type Routing route 53 | = Reader (Context route) 54 | 55 | type ROUTING route eff 56 | = ( routing ∷ Routing route | eff ) 57 | 58 | type ROUTING' routes eff 59 | = ( routing ∷ Routing (Variant routes) | eff ) 60 | 61 | printRoute ∷ ∀ v eff. v → Run ( ROUTING v + eff ) RelativeUrl 62 | printRoute v = map RelativeUrl $ askAt _routing <#> _.routeDuplex <#> flip D.print v 63 | 64 | printFullRoute ∷ ∀ v eff. v → Run ( ROUTING v + eff ) FullUrl 65 | printFullRoute v = printRoute v >>= toFullUrl 66 | 67 | toFullUrl ∷ ∀ v eff. RelativeUrl → Run ( ROUTING v + eff ) FullUrl 68 | toFullUrl (RelativeUrl str) = map FullUrl $ (<>) <$> (askAt _routing <#> _.domain) <@> str 69 | 70 | context ∷ ∀ v. Domain → D.RouteDuplex' v → String → Either D.RouteError (Context v) 71 | context domain routeDuplex@(RouteDuplex _ dec) = go 72 | where 73 | replacePlus = String.replaceAll (String.Pattern "+") (String.Replacement " ") 74 | 75 | go rawUrl = 76 | let 77 | routeState@{ params } = D.parsePath (replacePlus rawUrl) 78 | 79 | -- | TODO: Do we need this `query` value from the Duplex side? 80 | -- | It seems that we want to keep it here so we can be 81 | -- | consistent on the frontend. 82 | -- | `Query` is provided is separately by `WebRow.HTTP.Request` 83 | -- | where it is really expected. 84 | query = 85 | L.defer \_ → 86 | Query 87 | <<< Map.fromFoldableWith append 88 | <<< map (map Array.singleton) 89 | $ params 90 | 91 | -- | TODO: 92 | -- | * drop query (raw contains this info) 93 | -- | * move `raw` to `raw.parts` 94 | -- | * move `url` to `raw.fullPath` 95 | ctx = 96 | { domain 97 | -- | Drop `query` and provide combinator which builds it 98 | , query 99 | , raw: routeState 100 | , route: _ 101 | , routeDuplex 102 | , url: RelativeUrl rawUrl 103 | } 104 | in 105 | ctx 106 | <$> case D.runRouteParser routeState dec of 107 | D.Fail err → Left err 108 | D.Success _ res → Right res 109 | 110 | runRouting ∷ 111 | ∀ eff route. 112 | Domain → 113 | RouteDuplex' route → 114 | HTTPure.Request → 115 | Run (HTTPEXCEPT + REQUEST + ROUTING route + eff) 116 | ~> Run (HTTPEXCEPT + eff) 117 | runRouting domain routeDuplex request action = do 118 | case context domain routeDuplex request.url of 119 | Right routing → runReaders { request, routing } action 120 | Left _ → do 121 | notFound HTTPure.Headers.empty (BodyString "") 122 | 123 | route ∷ ∀ eff route. Run (ROUTING route + eff) route 124 | route = askAt _routing <#> _.route 125 | 126 | url ∷ ∀ eff route. Run (ROUTING route + eff) RelativeUrl 127 | url = askAt _routing <#> _.url 128 | 129 | redirect ∷ 130 | ∀ a eff route. 131 | route → 132 | Run 133 | ( HTTPEXCEPT 134 | + ROUTING route 135 | + eff 136 | ) 137 | a 138 | redirect r = printRoute r >>= fromRelativeUrl >>> HTTP.Response.redirect 139 | -------------------------------------------------------------------------------- /src/WebRow/Routing/Root.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Routing.Routing.Root where 2 | 3 | import Prelude 4 | import Data.Generic.Rep (class Generic) 5 | import Data.Symbol (SProxy(..)) 6 | import Data.Variant (Variant) 7 | import Prim.Row (class Lacks) as Row 8 | import Prim.RowList (class RowToList) 9 | import Record.Builder (Builder, build, insert) as Record.Builder 10 | import Routing.Duplex (RouteDuplex', root) as D 11 | import Routing.Duplex.Generic (noArgs, sum) as D 12 | import Routing.Duplex.Generic.Variant (class Variant') 13 | import Routing.Duplex.Generic.Variant (variant') as D 14 | 15 | data Root 16 | = Root 17 | 18 | derive instance genericRoot ∷ Generic Root _ 19 | 20 | _root = SProxy ∷ SProxy "" 21 | 22 | type Route routes 23 | = ( "" ∷ Root | routes ) 24 | 25 | type Duplex duplexes 26 | = ( "" ∷ D.RouteDuplex' Root | duplexes ) 27 | 28 | rootRouteDuplex ∷ D.RouteDuplex' Root 29 | rootRouteDuplex = D.sum { "Root": D.noArgs } 30 | 31 | build ∷ 32 | ∀ routes rl duplexes. 33 | RowToList (Duplex duplexes) rl ⇒ 34 | Variant' rl (Duplex duplexes) routes ⇒ 35 | Row.Lacks "" duplexes ⇒ 36 | Record.Builder.Builder {} (Record duplexes) → 37 | D.RouteDuplex' (Variant routes) 38 | build routesBuilder = 39 | D.root $ D.variant' 40 | $ Record.Builder.build 41 | (Record.Builder.insert _root rootRouteDuplex <<< routesBuilder) 42 | {} 43 | -------------------------------------------------------------------------------- /src/WebRow/Routing/Types.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Routing.Types where 2 | 3 | import Data.Lazy (Lazy) 4 | import Data.Newtype (class Newtype) 5 | import Polyform.Batteries.UrlEncoded (Query) 6 | import Routing.Duplex (RouteDuplex') as D 7 | import Routing.Duplex.Types (RouteState) as Routing.Duplex.Types 8 | 9 | newtype FullUrl 10 | = FullUrl String 11 | 12 | derive instance newtypeFullUrl ∷ Newtype FullUrl _ 13 | 14 | newtype RelativeUrl 15 | = RelativeUrl String 16 | 17 | derive instance newtypeRelativeUrl ∷ Newtype RelativeUrl _ 18 | 19 | newtype Url 20 | = Url String 21 | 22 | derive instance newtypeUrl ∷ Newtype Url _ 23 | 24 | fromFullUrl ∷ FullUrl → Url 25 | fromFullUrl (FullUrl url) = Url url 26 | 27 | fromRelativeUrl ∷ RelativeUrl → Url 28 | fromRelativeUrl (RelativeUrl url) = Url url 29 | 30 | type Domain 31 | = String 32 | 33 | type Context v 34 | = { domain ∷ Domain 35 | , routeDuplex ∷ D.RouteDuplex' v 36 | , raw ∷ Routing.Duplex.Types.RouteState 37 | , route ∷ v 38 | , query ∷ Lazy Query 39 | , url ∷ RelativeUrl 40 | } 41 | -------------------------------------------------------------------------------- /src/WebRow/Session.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Session where 2 | 3 | import Prelude 4 | 5 | import Data.Argonaut (Json) 6 | import Data.Either (hush) 7 | import Data.Lazy (force) 8 | import Data.Map (Map) 9 | import Data.Maybe (Maybe(..), fromMaybe) 10 | import Data.Validation.Semigroup (toEither) 11 | import Effect.Ref (Ref) 12 | import HTTPure (empty) as Headers 13 | import Polyform.Validator.Dual.Pure (Dual, runSerializer, runValidator) as Pure 14 | import Run (EFFECT, Run) 15 | import Run (interpret, lift, liftEffect, on, send) as Run 16 | import Type.Row (type (+)) 17 | import Type.Prelude (Proxy(..)) 18 | import WebRow.Cache (Key) 19 | import WebRow.HTTP (HTTPEXCEPT, internalServerError) 20 | import WebRow.HTTP.Cookies (Attributes, attributes, delete, lookup, lookupJson, set, setJson) as Cookies 21 | import WebRow.HTTP.Cookies (COOKIES) 22 | import WebRow.HTTP.Response.Types (Body(..)) 23 | import WebRow.Session.SessionStore (SessionStore, TTL(..)) 24 | import WebRow.Session.SessionStore (hoist) as SessionStore 25 | import WebRow.Session.SessionStore.InMemory (new) as SessionStore.InMemory 26 | 27 | data Session session a 28 | = Delete (Boolean → a) 29 | -- | When you fetch a given cookie you can extend its TTL. 30 | | Fetch (Maybe TTL) (session → a) 31 | | Save TTL session (Boolean → a) 32 | 33 | derive instance functorSession ∷ Functor (Session session) 34 | 35 | _session = Proxy ∷ Proxy "session" 36 | 37 | type SESSION session r 38 | = ( session ∷ Session session | r ) 39 | 40 | delete ∷ 41 | ∀ eff session. 42 | Run (SESSION session +eff) Boolean 43 | delete = Run.lift _session (Delete identity) 44 | 45 | modify ∷ 46 | ∀ eff session. 47 | TTL → (session → session) → Run (HTTPEXCEPT + SESSION session +eff) Unit 48 | modify ttl f = fetch Nothing >>= f >>> save ttl 49 | 50 | fetch ∷ 51 | ∀ eff session. 52 | Maybe TTL → 53 | Run (SESSION session +eff) session 54 | fetch ttl = Run.lift _session (Fetch ttl identity) 55 | 56 | save ∷ 57 | ∀ eff session. 58 | TTL → session → Run (HTTPEXCEPT + SESSION session +eff) Unit 59 | save ttl session = 60 | Run.lift _session (Save ttl session identity) >>= not 61 | >>> if _ then 62 | -- | TODO: 63 | -- | * Add loggin 64 | -- | * Handle this through custom internal exception variant? 65 | internalServerError Headers.empty $ BodyString "Serious problem on our side..." 66 | else 67 | pure unit 68 | 69 | cookieName ∷ Key 70 | cookieName = "session" 71 | 72 | runInStore ∷ 73 | ∀ eff session. 74 | SessionStore (Run (COOKIES + EFFECT + eff)) session → 75 | Maybe (TTL → Cookies.Attributes) → 76 | Run (COOKIES + EFFECT + SESSION session +eff) 77 | ~> Run (COOKIES + EFFECT + eff) 78 | runInStore store maybeToCookieAttributes action = do 79 | let 80 | toCookieAttributes = case maybeToCookieAttributes of 81 | Just f → f 82 | Nothing → \(TTL seconds) → Cookies.attributes _{ maxAge = Just seconds } 83 | 84 | handleSession ∷ 85 | Session session ~> Run (COOKIES + EFFECT + eff) 86 | handleSession (Delete next) = do 87 | void $ Cookies.delete cookieName 88 | store.delete >>= next >>> pure 89 | 90 | handleSession (Fetch maybeTtl next) = do 91 | -- | TODO: 92 | -- | * Should we raise here internalServerError when `set` returns `false`? 93 | -- | * Should we run testing cycle of test cookie setup? 94 | v ← store.fetch 95 | case maybeTtl of 96 | Just ttl → do 97 | let 98 | attributes = toCookieAttributes ttl 99 | void $ store.save ttl v 100 | void $ Cookies.set cookieName { value: force store.key, attributes } 101 | Nothing → pure unit 102 | pure (next v) 103 | 104 | handleSession (Save ttl@(TTL seconds) v next) = do 105 | let 106 | attributes = Cookies.attributes _{ maxAge = Just seconds } 107 | void $ Cookies.set cookieName { value: force store.key, attributes } 108 | a ← store.save ttl v 109 | pure (next a) 110 | Run.interpret (Run.on _session handleSession Run.send) action 111 | 112 | -- | Session store useful rather in the testing context. 113 | runInMemoryStore ∷ 114 | ∀ a eff session. 115 | Ref (Map String session) → 116 | session → 117 | Maybe (TTL → Cookies.Attributes) → 118 | Run (COOKIES + EFFECT + SESSION session +eff) a → 119 | Run (COOKIES + EFFECT + eff) a 120 | runInMemoryStore ref defaultSession maybeToCookieAttributes action = do 121 | -- | This laziness is a myth let's drop this all together 122 | lazySessionKey ← Cookies.lookup cookieName 123 | effSessionStore ← 124 | Run.liftEffect 125 | $ SessionStore.InMemory.new ref defaultSession lazySessionKey 126 | runInStore (SessionStore.hoist Run.liftEffect $ effSessionStore) maybeToCookieAttributes action 127 | 128 | -- | The whole session is stored in a cookie value so visible in the browser. 129 | -- | We don't need any cache here. We could possibly use Cache.Interpret.InCookies 130 | -- | but this seems to only complicate the implementation. 131 | runInCookieValue ∷ 132 | ∀ a eff err session. 133 | Pure.Dual err Json session → 134 | Run (COOKIES + EFFECT + eff) session → 135 | Maybe (TTL → Cookies.Attributes) → 136 | Run (COOKIES + EFFECT + SESSION session +eff) a → 137 | Run (COOKIES + EFFECT + eff) a 138 | runInCookieValue dual defaultSession maybeToCookieAttributes = 139 | let 140 | toCookieAttributes = case maybeToCookieAttributes of 141 | Just f → f 142 | Nothing → \(TTL seconds) → Cookies.attributes _{ maxAge = Just seconds } 143 | fetchFromCookie = do 144 | default ← defaultSession 145 | decode default <<< force <$> Cookies.lookupJson cookieName 146 | where 147 | decode default maybeRepr = 148 | fromMaybe default 149 | $ (maybeRepr >>= Pure.runValidator dual >>> toEither >>> hush) 150 | 151 | handleSession ∷ Session session ~> Run (COOKIES + EFFECT + eff) 152 | handleSession (Delete next) = do 153 | void $ Cookies.delete cookieName 154 | pure (next true) 155 | 156 | handleSession (Fetch ttl next) = do 157 | session ← fetchFromCookie 158 | let 159 | json = Pure.runSerializer dual session 160 | -- | TODO: 161 | -- | * Handle custom cookie attributes (expiration etc.). 162 | -- | * Should we raise here internalServerError when `set` returns `false`? 163 | -- | * Should we run testing cycle of test cookie setup? 164 | case ttl of 165 | Just t → do 166 | let 167 | attributes = toCookieAttributes t 168 | void $ Cookies.setJson cookieName { json, attributes } 169 | Nothing → pure unit 170 | pure $ next session 171 | 172 | handleSession (Save ttl v next) = do 173 | let 174 | json = Pure.runSerializer dual v 175 | attributes = toCookieAttributes ttl 176 | void $ Cookies.setJson cookieName { json, attributes } 177 | pure (next true) 178 | in 179 | Run.interpret (Run.on _session handleSession Run.send) 180 | -------------------------------------------------------------------------------- /src/WebRow/Session/SessionStore.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Session.SessionStore where 2 | 3 | import Prelude 4 | 5 | import Data.Lazy (Lazy, force) 6 | import Data.Maybe (fromMaybe) 7 | import Data.Time.Duration (Seconds) 8 | import Prim.Row (class Union) as Row 9 | import Run (Run) 10 | import Run (expand) as Run 11 | import WebRow.Cache (Interface, Key) as Cache 12 | 13 | newtype TTL = TTL Seconds 14 | 15 | type SessionStore m session 16 | = { delete ∷ m Boolean 17 | , fetch ∷ m session 18 | , key ∷ Lazy Cache.Key 19 | , save ∷ TTL → session → m Boolean 20 | } 21 | 22 | hoist ∷ ∀ a m m'. (m ~> m') → SessionStore m a → SessionStore m' a 23 | hoist h s = 24 | { delete: h s.delete 25 | , fetch: h s.fetch 26 | , key: s.key 27 | , save: \ttl → h <$> s.save ttl 28 | } 29 | 30 | expand ∷ 31 | ∀ a eff sEff sEff_. 32 | Row.Union sEff sEff_ eff ⇒ 33 | SessionStore (Run sEff) a → 34 | SessionStore (Run eff) a 35 | expand = hoist Run.expand 36 | 37 | -- new ∷ 38 | -- ∀ attrs m session. 39 | -- Monad m ⇒ 40 | -- session → 41 | -- Cache.Interface m { ttl ∷ Milliseconds | attrs } session → 42 | -- m (SessionStore m session) 43 | -- new default kv = 44 | -- kv.new 45 | -- >>= \k → 46 | -- pure 47 | -- { delete: kv.delete k 48 | -- , fetch: kv.get k >>= fromMaybe default >>> pure 49 | -- , key: defer \_ → k 50 | -- , save: kv.put k 51 | -- } 52 | 53 | forKey ∷ 54 | ∀ m session. 55 | Monad m ⇒ 56 | session → 57 | Lazy Cache.Key → 58 | Cache.Interface m TTL session → 59 | SessionStore m session 60 | forKey default k kv = 61 | { delete: kv.delete (force k) 62 | , fetch: kv.lookup (force k) >>= fromMaybe default >>> pure 63 | , key: k 64 | , save: \ttl v → kv.insert (force k) ttl v 65 | } 66 | -------------------------------------------------------------------------------- /src/WebRow/Session/SessionStore/InMemory.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Session.SessionStore.InMemory where 2 | 3 | import Prelude 4 | 5 | import Data.Lazy (Lazy) 6 | import Data.Map (Map) 7 | import Data.Maybe (Maybe, fromMaybe) 8 | import Data.UUID (genUUID) 9 | import Data.UUID (toString) as UUID 10 | import Effect (Effect) 11 | import Effect.Ref (Ref) 12 | import WebRow.Cache (Key) 13 | import WebRow.Cache.Interpret.InMemory (forRef) as Cache.InMemory 14 | import WebRow.Session.SessionStore (SessionStore) 15 | import WebRow.Session.SessionStore (forKey) as SessionStore 16 | 17 | new ∷ ∀ session. Ref (Map String session) → session → Lazy (Maybe Key) → Effect (SessionStore Effect session) 18 | new ref defaultSession maybeKey = do 19 | let 20 | kv = Cache.InMemory.forRef ref 21 | newKey ← UUID.toString <$> genUUID 22 | let 23 | key = fromMaybe newKey <$> maybeKey 24 | pure $ SessionStore.forKey defaultSession key kv 25 | 26 | 27 | -------------------------------------------------------------------------------- /src/WebRow/Testing.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Testing where 2 | -------------------------------------------------------------------------------- /src/WebRow/Testing/Assertions.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Testing.Assertions where 2 | 3 | import Prelude 4 | import Run (Run, liftEffect) 5 | import Test.Spec.Assertions (shouldEqual) as Assertions 6 | import Type.Row (type (+)) 7 | import WebRow.Contrib.Run (EffRow) 8 | 9 | shouldEqual ∷ ∀ a eff. Show a ⇒ Eq a ⇒ a → a → Run (EffRow + eff) Unit 10 | shouldEqual expected given = liftEffect $ Assertions.shouldEqual expected given 11 | -------------------------------------------------------------------------------- /src/WebRow/Testing/HTTP/Cookies.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Testing.HTTP.Cookies where 2 | 3 | import Prelude 4 | import Data.Array.NonEmpty (singleton) as Array.NonEmpty 5 | import Data.JSDate (JSDate) 6 | import Data.Map (filter, toUnfoldable) as Map 7 | import Data.Maybe (Maybe(..), fromMaybe) 8 | import Data.Profunctor.Strong ((***)) 9 | import Data.Tuple (Tuple) 10 | import Foreign.Object (fromFoldable) as Object 11 | import WebRow.HTTP.Cookies (Attributes(..), Values) as Cookies 12 | import WebRow.HTTP.Cookies (RequestCookies) 13 | import WebRow.Testing.HTTP.Types (ClientCookies) 14 | 15 | -- | We should probably abstract away expiration here 16 | -- | by just taking filtering function for cookies. 17 | dropExpired ∷ Maybe JSDate → ClientCookies → ClientCookies 18 | dropExpired Nothing = identity 19 | 20 | dropExpired (Just now) = Map.filter valid 21 | where 22 | valid { attributes: Cookies.Attributes { expires } } = fromMaybe false ((now < _) <$> expires) 23 | 24 | toRequestCookies ∷ ClientCookies -> RequestCookies 25 | toRequestCookies = 26 | let 27 | arr ∷ ClientCookies → Array (Tuple String Cookies.Values) 28 | arr = map (identity *** _.value >>> Array.NonEmpty.singleton) <<< Map.toUnfoldable 29 | in 30 | Object.fromFoldable <<< arr 31 | -------------------------------------------------------------------------------- /src/WebRow/Testing/HTTP/Response.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Testing.HTTP.Response where 2 | 3 | import Prelude 4 | 5 | import Data.Maybe (Maybe(..)) 6 | import HTTPure (Headers, header) as HTTPure 7 | import HTTPure (Status) 8 | import HTTPure.Headers (empty) as HTTPure.Headers 9 | import Run (Run) 10 | import Run (on, run, send) as Run 11 | import Run.Except (catchAt) 12 | import Type.Row (type (+)) 13 | import WebRow.HTTP (HTTPEXCEPT) 14 | import WebRow.HTTP (HTTPException) as HTTP 15 | import WebRow.HTTP.Response (HTTPResponse(..), Parts) as HTTP.Response 16 | import WebRow.HTTP.Response (HTTPResponse, SETHEADER, SetHeader(..), _httpExcept, _setHeader) 17 | import WebRow.HTTP.Response.Headers (setHeaderOnParts) 18 | import WebRow.HTTP.Response.Types (Body(..)) 19 | 20 | data Response res 21 | = HTTPException HTTP.HTTPException HTTPure.Headers 22 | | HTTPResponse { parts ∷ HTTP.Response.Parts, ctx ∷ res } 23 | 24 | derive instance functorResponse ∷ Functor Response 25 | 26 | status ∷ ∀ res. Response res → Maybe Status 27 | status (HTTPResponse { parts: { status: s } }) = Just s 28 | 29 | status _ = Nothing 30 | 31 | bodyString ∷ ∀ res. Response res → Maybe String 32 | bodyString (HTTPResponse { parts: { body: BodyString b } }) = Just b 33 | 34 | bodyString _ = Nothing 35 | 36 | -- type Response' body res = Response body (Variant res) 37 | type Render eff res 38 | = res → Run eff HTTPResponse 39 | 40 | runRender ∷ 41 | ∀ eff res. 42 | Render eff res → 43 | Run eff res → 44 | Run eff (Response res) 45 | runRender r rCtx = do 46 | ctx ← rCtx 47 | HTTP.Response.HTTPResponse parts ← r ctx 48 | pure $ HTTPResponse { parts, ctx } 49 | 50 | runHTTPExcept ∷ 51 | ∀ eff res. 52 | Run (HTTPEXCEPT + eff) (Response res) → 53 | Run eff (Response res) 54 | runHTTPExcept = catchAt _httpExcept (\e → pure $ HTTPException e HTTPure.Headers.empty) 55 | 56 | runSetHeader ∷ 57 | ∀ res eff. 58 | Run (SETHEADER + eff) (Response res) → 59 | Run eff (Response res) 60 | runSetHeader = 61 | Run.run 62 | $ Run.on _setHeader go Run.send 63 | where 64 | go (SetHeader k v a) = pure (set k v <$> a) 65 | 66 | set k v (HTTPException e h) = HTTPException e (HTTPure.header k v <> h) 67 | 68 | set k v (HTTPResponse { ctx, parts }) = HTTPResponse { ctx, parts: (setHeaderOnParts k v parts) } 69 | -------------------------------------------------------------------------------- /src/WebRow/Testing/HTTP/Types.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Testing.HTTP.Types where 2 | 3 | import WebRow.HTTP (ResponseCookies) 4 | 5 | -- | Client are just Response cookies aggregated and pruned 6 | -- | during http session life cycle. 7 | type ClientCookies 8 | = ResponseCookies 9 | -------------------------------------------------------------------------------- /src/WebRow/Testing/Interpret.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Testing.Interpret where 2 | 3 | import Prelude 4 | import Data.List (List) 5 | import Data.List (singleton) as List 6 | import Data.Tuple (Tuple) 7 | import JS.Unsafe.Stringify (unsafeStringify) 8 | import Run (Run) 9 | import Run (interpret, on, send) as Run 10 | import Run.Writer (Writer, runWriterAt, tellAt) 11 | import Type.Prelude (Proxy(..)) 12 | import Type.Row (type (+)) 13 | import WebRow.Mailer (MAILER, Mail, Mailer(..), _mailer) 14 | import WebRow.Message (MESSAGE, Message(..), _message) 15 | 16 | handleMessage ∷ ∀ m msgs. Monad m ⇒ Message msgs ~> m 17 | handleMessage (Message v next) = pure $ next (unsafeStringify v) 18 | 19 | runMessage ∷ ∀ eff msg. Run (MESSAGE msg + eff) ~> Run eff 20 | runMessage = Run.interpret (Run.on _message handleMessage Run.send) 21 | 22 | _mailQueue = Proxy ∷ Proxy "mailQueue" 23 | 24 | type MailQueue mails eff 25 | = ( mailQueue ∷ Writer (List (Mail mails)) | eff ) 26 | 27 | handleMail ∷ ∀ eff mails. Mailer mails ~> Run (MailQueue mails + eff) 28 | handleMail (Send mail next) = do 29 | tellAt _mailQueue (List.singleton mail) 30 | pure next 31 | 32 | runMailer ∷ ∀ eff mails. Run (MAILER mails + MailQueue mails + eff) ~> Run (MailQueue mails + eff) 33 | runMailer = Run.interpret (Run.on _mailer handleMail Run.send) 34 | 35 | runMailer' ∷ ∀ a eff mails. Run (MAILER mails + MailQueue mails + eff) a → Run (eff) (Tuple (List (Mail mails)) a) 36 | runMailer' = runWriterAt _mailQueue <<< runMailer 37 | -------------------------------------------------------------------------------- /src/WebRow/Testing/Messages.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Testing.Messages where 2 | 3 | import Prelude 4 | import Prim.Row (class Nub, class Union) as Row 5 | import Record.Builder (Builder, merge) as Record.Builder 6 | 7 | -- type Printers 8 | -- = ( invalidEmailFormat ∷ String → String ) 9 | -- 10 | -- printers ∷ { | Printers } 11 | -- printers = 12 | -- { invalidEmailFormat: 13 | -- \value → "Given value is not a valid email address: " <> show value 14 | -- } 15 | -- 16 | -- validators ∷ 17 | -- ∀ r r' r''. 18 | -- Row.Union r Printers r' ⇒ 19 | -- Row.Nub r' r'' ⇒ 20 | -- Record.Builder.Builder { | r } { | r'' } 21 | -- validators = Record.Builder.merge printers 22 | -------------------------------------------------------------------------------- /src/WebRow/Testing/Session.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Testing.Session where 2 | 3 | import Prelude 4 | 5 | import Data.Argonaut (Json) 6 | import Data.Lazy (defer) 7 | import Data.Map (Map) 8 | import Data.Maybe (Maybe) 9 | import Effect (Effect) 10 | import Effect.Ref (Ref) 11 | import Polyform.Validator.Dual.Pure (Dual) as Pure 12 | import Run (Run, EFFECT) 13 | import Run (interpret, liftEffect, on, send) as Run 14 | import Type.Row (type (+)) 15 | import WebRow.Forms.Payload (Key) 16 | import WebRow.Session (Session(..), SESSION, _session) 17 | import WebRow.Session.SessionStore (SessionStore) 18 | import WebRow.Session.SessionStore (hoist) as SessionStore 19 | import WebRow.Session.SessionStore.InMemory (new) as SessionStore.InMemory 20 | 21 | type SessionStoreConfig session 22 | = { default ∷ session 23 | , key ∷ Maybe Key 24 | , ref ∷ Ref (Map String session) 25 | } 26 | 27 | handleSession ∷ 28 | ∀ eff session. 29 | Effect (SessionStore (Run (EFFECT + eff)) session) → Session session ~> Run (EFFECT + eff) 30 | handleSession ss (Delete next) = Run.liftEffect ss >>= _.delete >>= next >>> pure 31 | 32 | handleSession ss (Fetch _ next) = Run.liftEffect ss >>= _.fetch >>= next >>> pure 33 | 34 | handleSession ss (Save ttl v next) = do 35 | ss' ← Run.liftEffect ss 36 | ss'.save ttl v >>= next >>> pure 37 | 38 | run ∷ 39 | ∀ eff session. 40 | Effect (SessionStore (Run (EFFECT + eff)) session) → 41 | Run (EFFECT + SESSION session + eff) 42 | ~> Run (EFFECT + eff) 43 | run ss action = Run.interpret (Run.on _session (handleSession ss) Run.send) action 44 | 45 | runInMemory ∷ 46 | ∀ a eff session. 47 | SessionStoreConfig session → 48 | Run (EFFECT + SESSION session + eff) a → 49 | Run (EFFECT + eff) a 50 | runInMemory { default, key, ref } action = do 51 | let 52 | ss = SessionStore.InMemory.new ref default (defer \_ → key) 53 | 54 | ss' = map (SessionStore.hoist Run.liftEffect) $ ss 55 | run ss' action 56 | 57 | type SessionCookieConfig session 58 | = { default ∷ session 59 | , dual ∷ ∀ err. Pure.Dual err Json session 60 | } 61 | -------------------------------------------------------------------------------- /src/WebRow/Testing/Templates.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Testing.Templates where 2 | 3 | import Prelude 4 | 5 | import Data.Array (head) as Array 6 | import Data.Foldable (for_) 7 | import Data.Functor.Variant (VariantF) 8 | import Data.Functor.Variant (case_, on) as VariantF 9 | import Data.Lazy (force) as Lazy 10 | import Data.Maybe (Maybe(..), fromMaybe) 11 | import Polyform.Batteries (Msg) 12 | import Text.Smolder.HTML (Html) 13 | import Text.Smolder.HTML (div, form, h2, html, input, p) as M 14 | import Text.Smolder.HTML.Attributes as A 15 | import Text.Smolder.Markup ((!)) 16 | import Text.Smolder.Markup (text) as M 17 | import Text.Smolder.Renderer.String as S 18 | import Type.Row (type (+)) 19 | import WebRow.Forms (Layout, LayoutBase(..), TextInput) as Forms 20 | import WebRow.Forms.Widgets (TextInputProps(..), _textInput) 21 | 22 | str ∷ ∀ msg. Msg msg → String 23 | str { msg } = Lazy.force msg 24 | 25 | html ∷ Html Unit → String 26 | html body = S.render $ M.html ! A.lang "en" $ body 27 | 28 | type FormLayout widgets msg 29 | = Forms.Layout (Msg msg) (Forms.TextInput () + widgets) 30 | 31 | type RenderWidgets widgets msg 32 | = VariantF widgets (Msg msg) → Html Unit 33 | 34 | formBody ∷ ∀ msg widgets. RenderWidgets widgets msg → FormLayout widgets msg → Html Unit 35 | formBody renderExtra (Forms.Section { closed, errors, layout }) = do 36 | -- | TODO: Render form errors 37 | for_ errors \msg → M.p $ M.text (str msg) 38 | case closed of 39 | Just { title } → for_ title \t → M.h2 $ M.text (str t) 40 | Nothing → pure unit 41 | for_ layout (formBody renderExtra) 42 | 43 | formBody renderExtra (Forms.Widget { widget }) = 44 | M.div 45 | $ do 46 | renderWidget widget 47 | where 48 | renderWidget = 49 | renderExtra 50 | # VariantF.on _textInput \(TextInputProps { name, payload, result, type_ }) → do 51 | for_ result case _ of 52 | Just errors → 53 | for_ errors \msg → 54 | M.p $ M.text (str msg) 55 | otherwise → pure unit 56 | M.input ! A.type' type_ ! A.name name ! A.value (fromMaybe "" (payload >>= Array.head)) 57 | 58 | form ∷ ∀ msg widgets. RenderWidgets widgets msg → FormLayout widgets msg → Html Unit 59 | form renderExtra l = do 60 | M.form ! A.method "post" 61 | $ do 62 | formBody renderExtra l 63 | M.input ! A.type' "submit" ! A.value "submit" 64 | 65 | -- { dangerouslySetInnerHTML: { __html : "UNSAFE" }} 66 | form' ∷ ∀ msg. FormLayout () msg → Html Unit 67 | form' = form VariantF.case_ 68 | -------------------------------------------------------------------------------- /src/WebRow/Types.purs: -------------------------------------------------------------------------------- 1 | module WebRow.Types where 2 | 3 | import Data.Variant (Variant) 4 | import Type.Prelude (SProxy(..)) 5 | import Type.Row (type (+)) 6 | import WebRow.HTTP (HTTPEXCEPT, REQUEST, COOKIES) 7 | import WebRow.Message (MESSAGE) 8 | import WebRow.Routing (ROUTING') 9 | import WebRow.Session (SESSION) 10 | 11 | _webrow = SProxy ∷ SProxy "webrow" 12 | 13 | type WebRow messages session routes eff 14 | = ( COOKIES 15 | + HTTPEXCEPT 16 | + MESSAGE (Variant messages) 17 | + REQUEST 18 | + ROUTING' routes 19 | + SESSION session 20 | + eff 21 | ) 22 | -------------------------------------------------------------------------------- /src/WebRow/UUID.purs: -------------------------------------------------------------------------------- 1 | module WebRow.UUID where 2 | 3 | import Prelude 4 | 5 | import Data.UUID (UUID) 6 | import Data.UUID (genUUID) as UUID 7 | import Run (Run, on) 8 | import Run (interpret, liftEffect, send) as Run 9 | import Type.Prelude (Proxy(..)) 10 | import Type.Row (type (+)) 11 | import WebRow.Contrib.Run (EffRow) 12 | 13 | newtype GenUUID a = GenUUID (UUID → a) 14 | 15 | derive instance functorUUIDF ∷ Functor GenUUID 16 | 17 | type GENUUID eff = (genUUID ∷ GenUUID | eff) 18 | 19 | _genUUID = Proxy ∷ Proxy "genUUID" 20 | 21 | run ∷ ∀ eff. Run (EffRow + GENUUID + eff) ~> Run (EffRow + eff) 22 | run = Run.interpret (on _genUUID handleUuid Run.send) 23 | where 24 | handleUuid ∷ ∀ b. GenUUID b → Run (EffRow + eff) b 25 | handleUuid (GenUUID next) = next <$> Run.liftEffect UUID.genUUID 26 | 27 | -------------------------------------------------------------------------------- /test/Main.purs: -------------------------------------------------------------------------------- 1 | module Test.Main where 2 | 3 | import Prelude 4 | 5 | import Effect (Effect) 6 | import Effect.Aff (launchAff_) 7 | import Test.Spec.Reporter (consoleReporter) 8 | import Test.Spec.Runner (runSpec) 9 | import Test.WebRow.Applets (spec) as Applets 10 | import Test.WebRow.HTTP (spec) as HTTP 11 | import Test.WebRow.I18N (spec) as I18N 12 | import Test.WebRow.PostgreSQL.Config (load) as Test.PostgreSQL.Config 13 | import Test.WebRow.PostgreSQL.PG (spec) as PG 14 | import Test.WebRow.Selda (spec) as Selda 15 | import Test.WebRow.Session (spec) as Session 16 | 17 | main :: Effect Unit 18 | main = launchAff_ $ do 19 | 20 | -- | I have to extract common Aff actions here 21 | -- | like pg pool construction so I don't repeat 22 | -- | it on every test entry. 23 | pool ← Test.PostgreSQL.Config.load 24 | runSpec [consoleReporter] do 25 | I18N.spec 26 | Applets.spec 27 | HTTP.spec 28 | Session.spec 29 | 30 | PG.spec pool 31 | Selda.spec pool 32 | -------------------------------------------------------------------------------- /test/WebRow/Applets.purs: -------------------------------------------------------------------------------- 1 | module Test.WebRow.Applets where 2 | 3 | import Prelude 4 | 5 | import Test.Spec (Spec, describe) 6 | import Test.WebRow.Applets.Auth (spec) as Test.Webrow.Applets.Auth 7 | import Test.WebRow.Applets.Registration (spec) as Test.Webrow.Applets.Registration 8 | 9 | spec ∷ Spec Unit 10 | spec = do 11 | describe "WebRow.Applets" do 12 | Test.Webrow.Applets.Auth.spec 13 | Test.Webrow.Applets.Registration.spec 14 | -------------------------------------------------------------------------------- /test/WebRow/Applets/Auth.purs: -------------------------------------------------------------------------------- 1 | module Test.WebRow.Applets.Auth where 2 | 3 | import Prelude 4 | 5 | import Data.Map (empty) as Map 6 | import Data.Maybe (Maybe(..)) 7 | import Data.Newtype (un) 8 | import Data.Time.Duration (Seconds(..)) 9 | import Data.Variant (Variant, case_, inj, on) 10 | import Effect.Class (liftEffect) as Effect 11 | import Effect.Class.Console (log) 12 | import Effect.Ref (new, read) as Ref 13 | import JS.Unsafe.Stringify (unsafeStringify) 14 | import Record.Builder (build) as Record.Builder 15 | import Routing.Duplex (RouteDuplex', print, root) as D 16 | import Routing.Duplex.Generic.Variant (variant') as RouteDuplex.Variant 17 | import Run (Run, liftEffect, runBaseAff') 18 | import Run (on, run, send) as Run 19 | import Test.Spec (Spec, describe, it) 20 | import Test.Spec.Assertions (fail, shouldEqual) 21 | import Type.Row (type (+)) 22 | import WebRow.Applets.Auth (RouteRow, routeBuilder, router) as Auth 23 | import WebRow.Applets.Auth.Effects (AUTH, Auth(..)) 24 | import WebRow.Applets.Auth.Routes (Route(..)) as Auth.Routes 25 | import WebRow.Applets.Auth.Testing.Templates (render) as Templates 26 | import WebRow.Applets.Auth.Types (Password(..), _auth) 27 | import WebRow.Mailer (Email(..)) 28 | import WebRow.Routing (route) 29 | import WebRow.Session (fetch) as Session 30 | import WebRow.Session.SessionStore (TTL(..)) 31 | import WebRow.Testing.HTTP (get, post, run) as T.H 32 | import WebRow.Testing.HTTP.Response (Response(..)) as T.H.R 33 | import WebRow.Testing.Interpret (runMessage) as Testing.Interpret 34 | 35 | type Route = Variant (Auth.RouteRow + ()) 36 | 37 | routeDuplex ∷ D.RouteDuplex' Route 38 | routeDuplex = D.root $ RouteDuplex.Variant.variant' routes 39 | where 40 | routes = Record.Builder.build Auth.routeBuilder {} 41 | 42 | runAuth ∷ ∀ eff. Run (AUTH () + eff) ~> Run eff 43 | runAuth = Run.run (Run.on _auth handler Run.send) 44 | where 45 | handler (Authenticate email password next) = do 46 | if email == Email "user@example.com" && un Password password == "correct" 47 | then pure $ next (Just { email }) 48 | else pure $ next Nothing 49 | 50 | ttl :: TTL 51 | ttl = TTL $ Seconds $ 60.0 * 60.0 * 24.0 * 3.0 52 | 53 | server = Testing.Interpret.runMessage $ runAuth $ bind route $ case_ 54 | # Auth.router ttl 55 | 56 | render = case_ 57 | # on _auth Templates.render 58 | 59 | spec ∷ Spec Unit 60 | spec = do 61 | describe "Auth" do 62 | describe "login" do 63 | it "flow" do 64 | ref ← Effect.liftEffect $ Ref.new Map.empty 65 | let 66 | sessionStorageConfig = 67 | { default: { user: Nothing }, ref, key: Nothing } 68 | client = do 69 | let 70 | loginUrl = (D.print routeDuplex (inj _auth Auth.Routes.Login)) 71 | 72 | response ← T.H.post loginUrl 73 | { "email": "user@example.com" 74 | , "password": "wrong" 75 | } 76 | 77 | -- | TODO: 78 | -- | Refector this piece out into something like 79 | -- | `Webrow.Testing.Spec.post` which expects status code etc. 80 | liftEffect $ case response of 81 | T.H.R.HTTPResponse r → r.parts.status `shouldEqual` 200 82 | T.H.R.HTTPException _ _ → fail "Unexpected exception" 83 | 84 | s ← Session.fetch (Just ttl) 85 | liftEffect $ log "\nSession:" 86 | liftEffect $ log $ unsafeStringify s 87 | 88 | response ← T.H.post loginUrl 89 | { "email": "user@example.com" 90 | , "password": "correct" 91 | } 92 | liftEffect $ log "\nLogin correct response:" 93 | liftEffect $ log $ unsafeStringify response 94 | 95 | s ← Session.fetch (Just ttl) 96 | liftEffect $ log "\nSession:" 97 | liftEffect $ log $ unsafeStringify s 98 | void $ T.H.get "2" 99 | 100 | let 101 | logoutUrl = (D.print routeDuplex (inj _auth Auth.Routes.Logout)) 102 | 103 | response ← T.H.post logoutUrl {} 104 | 105 | liftEffect $ log ("\nLogout response (" <> unsafeStringify logoutUrl <> "):") 106 | liftEffect $ log $ unsafeStringify response 107 | 108 | s ← Session.fetch (Just ttl) 109 | liftEffect $ log "\nSession:" 110 | liftEffect $ log $ unsafeStringify s 111 | 112 | httpSession ← runBaseAff' $ T.H.run sessionStorageConfig routeDuplex render server client 113 | Effect.liftEffect $ log "\nSession store:" 114 | Effect.liftEffect $ log =<< (Ref.read ref <#> unsafeStringify) 115 | pure unit 116 | 117 | -- logShow "The whole session:" 118 | -- logShow $ unsafeStringify httpSession 119 | 120 | -------------------------------------------------------------------------------- /test/WebRow/Applets/Registration.purs: -------------------------------------------------------------------------------- 1 | module Test.WebRow.Applets.Registration where 2 | 3 | import Prelude 4 | 5 | import Data.Foldable (length) 6 | import Data.List ((:)) 7 | import Data.List (List(..)) as List 8 | import Data.Map (empty) as Map 9 | import Data.Maybe (Maybe(..)) 10 | import Data.Tuple (Tuple(..)) 11 | import Data.Variant (Variant, case_, inj, on) 12 | import Effect.Class (liftEffect) as Effect 13 | import Effect.Ref (new) as Effect.Ref 14 | import JS.Unsafe.Stringify (unsafeStringify) 15 | import Polyform.Batteries.UrlEncoded.Validators (MissingValue) 16 | import Record.Builder (build) as Record.Builder 17 | import Routing.Duplex (RouteDuplex', print, root) as D 18 | import Routing.Duplex.Generic.Variant (variant') as RouteDuplex.Variant 19 | import Run (Run, runBaseAff') 20 | import Run (on, run, send) as Run 21 | import Test.Spec (Spec, describe, it) 22 | import Test.Spec.Assertions (fail, shouldEqual) 23 | import Test.WebRow.Applets.Auth (runAuth, ttl) 24 | import Type.Row (type (+)) 25 | import WebRow.Applets.Auth (Messages, ResponseRow, RouteRow, routeBuilder, router) as Auth 26 | import WebRow.Applets.Auth.Effects (Auth, AUTH) 27 | import WebRow.Applets.Auth.Testing.Templates (render) as A.Templates 28 | import WebRow.Applets.Auth.Types (Password(..), _auth) 29 | import WebRow.Applets.Registration (Messages, ResponseRow, RouteRow, router) as Registration 30 | import WebRow.Applets.Registration (Route(..)) as Registration.Routes 31 | import WebRow.Applets.Registration (routeBuilder) as Registartion 32 | import WebRow.Applets.Registration.Effects (Registration(..), REGISTRATION) 33 | import WebRow.Applets.Registration.Testing.Templates (render) as R.Templates 34 | import WebRow.Applets.Registration.Types (_registration) 35 | import WebRow.Crypto (Crypto, CRYPTO) 36 | import WebRow.Forms.Validators (InvalidEmailFormat) 37 | import WebRow.HTTP (HTTPResponse) 38 | import WebRow.Mailer (Email(..), Mailer, MAILER) 39 | import WebRow.Routing (FullUrl, ROUTING', route) 40 | import WebRow.Testing.HTTP (post_, run) as T.H 41 | import WebRow.Testing.Interpret (runMailer') 42 | import WebRow.Testing.Interpret (runMessage) as Testing.Interpret 43 | import WebRow.Types (WebRow) 44 | 45 | type RouteRow 46 | = (Auth.RouteRow + Registration.RouteRow + ()) 47 | 48 | type MessageRow 49 | = ( Auth.Messages 50 | + Registration.Messages 51 | + InvalidEmailFormat 52 | + MissingValue 53 | + () 54 | ) 55 | 56 | type ResponseRow 57 | = (Auth.ResponseRow + Registration.ResponseRow + ()) 58 | 59 | routeDuplex ∷ D.RouteDuplex' (Variant RouteRow) 60 | routeDuplex = D.root $ RouteDuplex.Variant.variant' routes 61 | where 62 | routes = 63 | Record.Builder.build 64 | (Auth.routeBuilder <<< Registartion.routeBuilder) 65 | {} 66 | 67 | runRegistration ∷ ∀ eff. Run (REGISTRATION + eff) ~> Run eff 68 | runRegistration = Run.run (Run.on _registration handler Run.send) 69 | where 70 | handler (EmailTakenF (Email email) next) = pure (next $ email == "already-registered@example.com") 71 | 72 | handler (RegisterF (Email email) (Password password) next) = pure next 73 | 74 | render ∷ 75 | ∀ eff. 76 | Variant ResponseRow → 77 | Run (ROUTING' RouteRow + eff) HTTPResponse 78 | render = 79 | case_ 80 | # on _auth A.Templates.render 81 | # on _registration R.Templates.render 82 | 83 | type UserSession 84 | = { user ∷ Maybe { email ∷ Email } } 85 | 86 | -- | Handling through this localRouter 87 | -- x = 88 | -- { registration: Registration.localRouter 89 | -- , auth: Auth.localRouter 90 | -- } 91 | server ∷ 92 | ∀ eff mails. 93 | Run 94 | ( AUTH () 95 | + CRYPTO 96 | + MAILER ( emailVerification ∷ FullUrl | mails ) 97 | + REGISTRATION 98 | + WebRow 99 | MessageRow 100 | UserSession 101 | RouteRow 102 | + eff 103 | ) 104 | (Variant ResponseRow) 105 | server = 106 | bind route $ case_ 107 | # Registration.router 108 | # Auth.router ttl 109 | 110 | spec ∷ Spec Unit 111 | spec = do 112 | describe "Registration" do 113 | describe "registerEmail" do 114 | let 115 | run ref c = do 116 | let 117 | sessionStorageConfig = { default: { user: Nothing }, ref, key: Nothing } 118 | runBaseAff' 119 | $ Testing.Interpret.runMessage 120 | $ runAuth 121 | $ runMailer' 122 | $ runRegistration 123 | $ (T.H.run sessionStorageConfig routeDuplex render server c) 124 | it "fails for already registered email" do 125 | ref ← Effect.liftEffect $ Effect.Ref.new Map.empty 126 | Tuple mails httpSession ← 127 | run ref do 128 | let 129 | registrationUrl = (D.print routeDuplex (inj _registration Registration.Routes.RegisterEmail)) 130 | T.H.post_ registrationUrl { "email": "already-registered@example.com" } 131 | length mails `shouldEqual` 0 132 | it "sends registration mail to the new address" do 133 | ref ← Effect.liftEffect $ Effect.Ref.new Map.empty 134 | let 135 | email = "not-taken@example.com" 136 | Tuple mails httpSession ← 137 | run ref do 138 | let 139 | registrationUrl = (D.print routeDuplex (inj _registration Registration.Routes.RegisterEmail)) 140 | T.H.post_ registrationUrl { email } 141 | case mails of 142 | { to } : List.Nil → to `shouldEqual` (Email email) 143 | otherwise → 144 | fail 145 | $ "Single registration email should be sent - mail queue state: " 146 | <> unsafeStringify mails 147 | -------------------------------------------------------------------------------- /test/WebRow/HTTP.purs: -------------------------------------------------------------------------------- 1 | module Test.WebRow.HTTP where 2 | 3 | import Prelude hiding ((/)) 4 | import Data.Lazy (force) as Lazy 5 | import Data.Maybe (Maybe(..)) 6 | import Effect.Class (liftEffect) 7 | import Effect.Class.Console (logShow) 8 | import Effect.Random (random) 9 | import JS.Unsafe.Stringify (unsafeStringify) 10 | import Routing.Duplex.Generic (noArgs) 11 | import Run (runBaseAff') 12 | import Test.Spec (Spec, describe, it) 13 | import WebRow.Crypto (secret) as Crypto 14 | import WebRow.HTTP (fullPath) as HTTP 15 | import WebRow.HTTP.Cookies (defaultAttributes, lookup, set) as Cookies 16 | import WebRow.HTTP.Response (ok) 17 | import WebRow.Session (fetch) as Session 18 | import WebRow.Testing.Assertions (shouldEqual) 19 | import WebRow.Testing.HTTP (get, get_) 20 | import WebRow.Testing.HTTP (run') as Testing.HTTP 21 | import WebRow.Testing.HTTP.Response (bodyString) as Response 22 | 23 | spec :: Spec Unit 24 | spec = do 25 | describe "WebRow.HTTP" do 26 | describe "Response" do 27 | it "SetHeader" do 28 | let 29 | client = do 30 | response ← get "1" 31 | Response.bodyString response `shouldEqual` Just "TEST" 32 | get_ "2" 33 | 34 | server = do 35 | path ← HTTP.fullPath 36 | cs ← Crypto.secret 37 | c ← Lazy.force <$> Cookies.lookup "test" 38 | liftEffect $ logShow c 39 | void $ Cookies.set "test" { value: "test", attributes: Cookies.defaultAttributes } 40 | r ← liftEffect $ random 41 | ok $ "TEST" -- (req.url <> ":" <> show r) 42 | httpSession <- runBaseAff' $ Testing.HTTP.run' {} noArgs pure server client 43 | logShow $ unsafeStringify httpSession 44 | pure unit 45 | describe "WebRow.Session" do 46 | describe "In cookie handling" do 47 | it "Should handle multiple cookie modifications" do 48 | let 49 | client = do 50 | response ← get "1" 51 | Response.bodyString response `shouldEqual` Just "TEST" 52 | get_ "2" 53 | 54 | server = do 55 | value ← Session.fetch Nothing 56 | cs ← Crypto.secret 57 | c ← Lazy.force <$> Cookies.lookup "test" 58 | liftEffect $ logShow c 59 | void $ Cookies.set "test" { value: "test", attributes: Cookies.defaultAttributes } 60 | r ← liftEffect $ random 61 | ok $ "TEST" -- (req.url <> ":" <> show r) 62 | httpSession <- runBaseAff' $ Testing.HTTP.run' {} noArgs pure server client 63 | logShow $ unsafeStringify httpSession 64 | pure unit 65 | 66 | -- pending "feature complete" 67 | -- describe "Features" do 68 | -- it "runs in NodeJS" $ pure unit 69 | -- it "runs in the browser" $ pure unit 70 | -- it "supports streaming reporters" $ pure unit 71 | -- it "supports async specs" do 72 | -- res <- delay (Milliseconds 100.0) $> "Alligator" 73 | -- res `shouldEqual` "Alligator" 74 | -- it "is PureScript 0.12.x compatible" $ pure unit 75 | -------------------------------------------------------------------------------- /test/WebRow/I18N.purs: -------------------------------------------------------------------------------- 1 | module Test.WebRow.I18N where 2 | 3 | import Prelude hiding ((/)) 4 | import Data.Either (hush) 5 | import Data.Generic.Rep (class Generic) 6 | import Data.Show.Generic (genericShow) 7 | import Data.Maybe (Maybe(..)) 8 | import Data.Variant (Variant) 9 | import Routing.Duplex (RouteDuplex', parse, print) 10 | import Routing.Duplex (int, root, segment) as Duplex 11 | import Routing.Duplex.Generic (noArgs) 12 | import Routing.Duplex.Generic (sum) as Duplex 13 | import Routing.Duplex.Generic.Syntax ((/)) 14 | import Test.Spec (Spec, describe, it) 15 | import Test.Spec.Assertions (shouldEqual) 16 | import Type.Prelude (SProxy(..)) 17 | import Type.Row (type (+)) 18 | import WebRow.I18N (languageCode, getLanguage) 19 | import WebRow.I18N.ISO639.TwoLetter (LanguageNames) 20 | import WebRow.I18N.Routing (duplex) as I18N.Routing 21 | 22 | type Latine r 23 | = ( la ∷ LanguageNames | r ) 24 | 25 | type Nepali r 26 | = ( ne ∷ LanguageNames | r ) 27 | 28 | type Urdu r 29 | = ( ur ∷ LanguageNames | r ) 30 | 31 | type Language 32 | = Variant (Latine + Nepali + Urdu ()) 33 | 34 | la ∷ Language 35 | la = getLanguage (SProxy ∷ SProxy "la") 36 | 37 | ne ∷ Language 38 | ne = getLanguage (SProxy ∷ SProxy "ne") 39 | 40 | ur ∷ Language 41 | ur = getLanguage (SProxy ∷ SProxy "ur") 42 | 43 | type Id 44 | = Int 45 | 46 | data ActualRoute 47 | = Home 48 | | Profile Id 49 | 50 | derive instance genericActualRoute ∷ Generic ActualRoute _ 51 | 52 | derive instance eqActualRoute ∷ Eq ActualRoute 53 | 54 | derive instance ordActualRoute ∷ Ord ActualRoute 55 | 56 | instance showActualRoute ∷ Show ActualRoute where 57 | show = genericShow 58 | 59 | actualRouteDuplex :: RouteDuplex' ActualRoute 60 | actualRouteDuplex = 61 | Duplex.sum 62 | { "Home": noArgs 63 | , "Profile": "profile" / Duplex.int Duplex.segment 64 | } 65 | 66 | duplex ∷ RouteDuplex' { language ∷ Language, route ∷ ActualRoute } 67 | duplex = Duplex.root $ I18N.Routing.duplex la actualRouteDuplex 68 | 69 | spec ∷ Spec Unit 70 | spec = do 71 | describe "I18N" do 72 | describe "route duplex" do 73 | it "should print translated path" do 74 | let 75 | path = print duplex ({ language: ur, route: Home }) 76 | shouldEqual "/ur" path 77 | it "should print empty prefix for default lang" do 78 | let 79 | path = print duplex ({ language: la, route: Home }) 80 | shouldEqual "/" path 81 | it "should parse translated path" do 82 | let 83 | lang = parse duplex ("/ur/profile/8") 84 | shouldEqual (hush lang <#> _.language >>> languageCode) (Just (languageCode ur)) 85 | shouldEqual (hush lang <#> _.route) (Just (Profile 8)) 86 | it "should parse default langauge path" do 87 | let 88 | lang = parse duplex ("/") 89 | shouldEqual (hush lang <#> _.language >>> languageCode) (Just (languageCode la)) 90 | -------------------------------------------------------------------------------- /test/WebRow/PostgreSQL/Config.purs: -------------------------------------------------------------------------------- 1 | module Test.WebRow.PostgreSQL.Config where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (throwError) 6 | import Data.Either (Either(..)) 7 | import Data.Map (fromFoldable) as Map 8 | import Data.Newtype (un) 9 | import Data.Validation.Semigroup (V(..)) 10 | import Database.PostgreSQL (Pool) 11 | import Database.PostgreSQL (new) as Pool 12 | import Database.PostgreSQL (Configuration) as PG 13 | import Dotenv (loadFile) as DotEnv 14 | import Effect.Aff (Aff) 15 | import Effect.Class (class MonadEffect, liftEffect) 16 | import Effect.Exception (error) 17 | import Foreign.Object (toUnfoldable) as Object 18 | import Node.Process (getEnv) 19 | import Polyform.Batteries.Env (Env, Validator) as Env 20 | import Polyform.Batteries.Env (MissingValue) 21 | import Polyform.Batteries.Env.Validators (optional, required) as Env 22 | import Polyform.Batteries.Int (IntExpected) 23 | import Polyform.Batteries.Int (validator) as Int 24 | import Polyform.Validator (liftFnM, runValidator) 25 | import Type.Row (type (+)) 26 | 27 | poolConfiguration 28 | ∷ ∀ err m 29 | . Monad m 30 | ⇒ Env.Validator m (IntExpected + MissingValue + err) Env.Env PG.Configuration 31 | poolConfiguration = { database: _, host: _, idleTimeoutMillis: _, max: _, password: _, port: _, user: _ } 32 | <$> Env.required "PG_DB" identity 33 | <*> Env.optional "PG_HOST" identity 34 | <*> Env.optional "PG_IDLE_TIMEOUT_MILLISECONDS" Int.validator 35 | <*> Env.optional "PG_MAX" Int.validator 36 | <*> Env.optional "PG_PASSWORD" identity 37 | <*> Env.optional "PG_PORT" Int.validator 38 | <*> Env.optional "PG_USER" identity 39 | 40 | pool ∷ ∀ err m. MonadEffect m ⇒ Env.Validator m (IntExpected + MissingValue + err) Env.Env Pool 41 | pool = poolConfiguration >>> liftFnM (Pool.new >>> liftEffect) 42 | 43 | load :: Aff Pool 44 | load = do 45 | void $ DotEnv.loadFile 46 | env ← liftEffect $ getEnv <#> (Object.toUnfoldable ∷ _ → Array _) >>> Map.fromFoldable 47 | runValidator pool env >>= un V >>> case _ of 48 | Left err → do 49 | throwError $ error "Configuration error. Please verify your environment and .env file." 50 | Right p → pure p 51 | -------------------------------------------------------------------------------- /test/WebRow/PostgreSQL/PG.purs: -------------------------------------------------------------------------------- 1 | module Test.WebRow.PostgreSQL.PG where 2 | 3 | import Prelude 4 | 5 | import Control.Monad.Error.Class (throwError) 6 | import Control.Monad.Except (catchError) 7 | import Data.Either (Either(..)) 8 | import Data.Maybe (Maybe(..)) 9 | import Database.PostgreSQL (PGError, Pool, fromPool) 10 | import Database.PostgreSQL.Aff (query) as PostgreSQL.Aff 11 | import Database.PostgreSQL.Pool (idleCount, totalCount) as Pool 12 | import Effect.Aff (Aff) 13 | import Effect.Class (liftEffect) 14 | import Effect.Exception (error) as Effect.Exception 15 | import JS.Unsafe.Stringify (unsafeStringify) 16 | import Run (AFF, Run, EFFECT) 17 | import Run (liftAff, liftEffect) as Run 18 | import Run.Except (catchAt, throwAt) 19 | import Selda (Table(..)) 20 | import Test.Spec (SpecT, describe, it) 21 | import Test.Spec.Assertions (shouldEqual) as Assertions 22 | import Test.Spec.Assertions (shouldEqual) as Spec 23 | import Type.Prelude (SProxy(..)) 24 | import Type.Row (type (+)) 25 | import WebRow.PostgreSQL (Outside, PGEXCEPT, Pg, Query(..), Row0(..), Row1, Row3(..), PG, _pgExcept) 26 | import WebRow.PostgreSQL (run) as PG 27 | import WebRow.PostgreSQL.PG (execute, query) as PG 28 | import WebRow.PostgreSQL.PG (withTransaction) 29 | import WebRow.Resource (RESOURCE, runBaseResource') 30 | import WebRow.Testing.Assertions (shouldEqual) 31 | 32 | type PeopleRow = ( age ∷ Maybe Int, id ∷ Int, name ∷ String ) 33 | type Person = { | PeopleRow } 34 | 35 | people ∷ Table PeopleRow 36 | people = Table { name: "people" } 37 | 38 | type PersonPGRow = Row3 Int String (Maybe Int) 39 | 40 | _testErr = SProxy ∷ SProxy "testErr" 41 | 42 | initDb ∷ ∀ eff mode. Run (PG mode + eff) Unit 43 | initDb = 44 | do 45 | let 46 | sql ∷ Query Row0 Row0 47 | sql = Query """ 48 | DROP TABLE IF EXISTS people; 49 | CREATE TABLE people ( 50 | id INTEGER PRIMARY KEY, 51 | name TEXT NOT NULL, 52 | age INTEGER 53 | ); 54 | 55 | DO $$ 56 | BEGIN 57 | IF NOT EXISTS (SELECT 1 FROM pg_type WHERE typname = 'account_type') THEN 58 | CREATE TYPE ACCOUNT_TYPE as ENUM ( 59 | 'business', 60 | 'personal' 61 | ); 62 | END IF; 63 | END$$; 64 | 65 | DROP TABLE IF EXISTS bank_accounts; 66 | CREATE TABLE bank_accounts ( 67 | id INTEGER PRIMARY KEY, 68 | "personId" INTEGER NOT NULL, 69 | balance INTEGER NOT NULL, 70 | "accountType" ACCOUNT_TYPE NOT NULL 71 | ); 72 | """ 73 | PG.execute sql Row0 74 | 75 | 76 | runTest ∷ ∀ a. Pool → Run (AFF + EFFECT + PG Outside + PGEXCEPT + RESOURCE + ()) a → Aff a 77 | runTest pool action = 78 | runBaseResource' 79 | <<< catchAt _pgExcept (\e → Run.liftEffect $ throwError $ Effect.Exception.error (unsafeStringify e)) 80 | <<< PG.run pool 81 | $ do 82 | initDb 83 | action 84 | 85 | spec ∷ ∀ m. Monad m ⇒ Pool → SpecT Aff Unit m Unit 86 | spec pool = do 87 | describe "WebRow.PostgreSQL.PG" do 88 | it "executes statements correctly" do 89 | runTest pool do 90 | p ← PG.query (Query "SELECT id from people") Row0 91 | p `shouldEqual` ([] ∷ Array (Row1 Int)) 92 | 93 | it "commits after transaction" do 94 | runTest pool do 95 | withTransaction $ do 96 | PG.execute (Query "INSERT into people (id, name, age) VALUES (1, 'foo', NULL)") Row0 97 | 98 | p ← PG.query (Query "SELECT id, name, age from people") Row0 99 | p `shouldEqual` ([ Row3 1 "foo" Nothing ] ∷ Array (Row3 Int String (Maybe Int))) 100 | 101 | totalCount ← liftEffect $ Pool.totalCount pool 102 | idleCount ← liftEffect $ Pool.idleCount pool 103 | idleCount `Spec.shouldEqual` totalCount 104 | 105 | it "rollbacks on exception" do 106 | let 107 | run' action 108 | = runBaseResource' 109 | <<< catchAt _pgExcept (\e → Run.liftEffect $ throwError $ Effect.Exception.error (unsafeStringify e)) 110 | -- <<< catchAt _testErr (\e → Run.liftEffect $ throwError $ Effect.Exception.error (unsafeStringify e)) 111 | <<< catchAt _testErr (const $ pure unit) 112 | <<< PG.run pool 113 | $ do 114 | initDb 115 | action 116 | 117 | run' do 118 | void $ withTransaction $ do 119 | PG.execute (Query "INSERT into people (id, name, age) VALUES (1, 'foo', NULL)") Row0 120 | throwAt _testErr "throw before COMMIT" 121 | 122 | (p ∷ Either _ (Array PersonPGRow)) ← PostgreSQL.Aff.query (fromPool pool) (Query "SELECT id, name, age from people") Row0 123 | p `Assertions.shouldEqual` (Right []) 124 | 125 | totalCount ← liftEffect $ Pool.totalCount pool 126 | idleCount ← liftEffect $ Pool.idleCount pool 127 | idleCount `Spec.shouldEqual` totalCount 128 | 129 | it "rollbacks on aff exception" do 130 | let 131 | run' action 132 | = action' `catchError` \e → pure unit 133 | where 134 | action' = runBaseResource' 135 | <<< catchAt _pgExcept (\e → Run.liftEffect $ throwError $ Effect.Exception.error (unsafeStringify e)) 136 | <<< catchAt _testErr (const $ pure unit) 137 | <<< PG.run pool 138 | $ do 139 | initDb 140 | action 141 | 142 | run' do 143 | void $ withTransaction $ do 144 | PG.execute (Query "INSERT into people (id, name, age) VALUES (1, 'foo', NULL)") Row0 145 | void $ Run.liftAff $ liftEffect $ throwError $ Effect.Exception.error "Aff throw before commit" 146 | 147 | (p ∷ Either _ (Array PersonPGRow)) ← PostgreSQL.Aff.query (fromPool pool) (Query "SELECT id, name, age from people") Row0 148 | p `Assertions.shouldEqual` (Right []) 149 | 150 | totalCount ← liftEffect $ Pool.totalCount pool 151 | idleCount ← liftEffect $ Pool.idleCount pool 152 | idleCount `Spec.shouldEqual` totalCount 153 | 154 | -------------------------------------------------------------------------------- /test/WebRow/PostgreSQL/Selda.purs: -------------------------------------------------------------------------------- 1 | module Test.WebRow.Selda where 2 | 3 | import Prelude 4 | import Data.Maybe (Maybe(..)) 5 | import Database.PostgreSQL (Pool) as PG 6 | import Effect.Aff (Aff) 7 | import Selda (selectFrom) 8 | import Test.Spec (SpecT, describe, it) 9 | import Test.WebRow.PostgreSQL.PG (people, runTest) 10 | import WebRow.PostgreSQL (withTransaction) 11 | import WebRow.PostgreSQL.Selda (insert1_, query, query1) 12 | import WebRow.Testing.Assertions (shouldEqual) 13 | 14 | spec :: forall m. Monad m => PG.Pool -> SpecT Aff Unit m Unit 15 | spec pool = do 16 | describe "WebRow.Selda" do 17 | it "performs trivial select" do 18 | runTest pool do 19 | p ← query $ selectFrom people pure 20 | p `shouldEqual` [] 21 | it "performs insert outside of transaction block" do 22 | let 23 | row = { id: 1, name: "foo", age: Nothing } 24 | runTest pool do 25 | insert1_ people row 26 | p ← query1 $ selectFrom people pure 27 | p `shouldEqual` (Just row) 28 | it "commits insert within transaction" do 29 | let 30 | row = { id: 1, name: "foo", age: Nothing } 31 | runTest pool do 32 | withTransaction 33 | $ insert1_ people row 34 | p ← query1 $ selectFrom people pure 35 | p `shouldEqual` (Just row) 36 | -------------------------------------------------------------------------------- /test/WebRow/Session.purs: -------------------------------------------------------------------------------- 1 | module Test.WebRow.Session where 2 | 3 | import Prelude 4 | 5 | import Data.Map (empty) as Map 6 | import Data.Maybe (Maybe(..)) 7 | import Data.Time.Duration (Seconds(..)) 8 | import Effect.Class (liftEffect) as Effect.Class 9 | import Effect.Exception (throw) 10 | import Effect.Ref (new) as Ref 11 | import Polyform.Batteries.Json.Duals (int) as Dual 12 | import Run (Run, EFFECT, liftEffect, runBaseEffect) 13 | import Run (on, run, send) as Run 14 | import Run.Except (catchAt) 15 | import Test.Spec (Spec, describe, it) 16 | import Type.Row (type (+)) 17 | import WebRow.Crypto (Secret(..)) 18 | import WebRow.HTTP (CookieStore(..), HTTPEXCEPT, SETHEADER) 19 | import WebRow.HTTP.Cookies (runOnStore) 20 | import WebRow.HTTP.Response (_httpExcept, _setHeader) 21 | import WebRow.Session (fetch, save) as Session 22 | import WebRow.Session (runInCookieValue, runInMemoryStore) 23 | import WebRow.Session.SessionStore (TTL(..)) 24 | import WebRow.Testing.Assertions (shouldEqual) 25 | 26 | spec :: Spec Unit 27 | spec = do 28 | let 29 | runHTTPExcept ∷ ∀ e. Run (EFFECT + HTTPEXCEPT + e) ~> Run (EFFECT + e) 30 | runHTTPExcept action = catchAt _httpExcept (const $ liftEffect $ throw $ "TEST") action 31 | 32 | runSetHeader ∷ ∀ e. Run (EFFECT + SETHEADER + e) Unit → Run (EFFECT + e) Unit 33 | runSetHeader = do 34 | Run.run 35 | $ Run.on 36 | _setHeader 37 | (const $ pure $ pure unit) 38 | Run.send 39 | describe "WebRow.Session" do 40 | let 41 | ttl = TTL $ Seconds $ 60.0 * 24.0 * 3.0 42 | describe "in cookie value" do 43 | it "performs sudbsquent updates correctly" do 44 | let 45 | cookieStore = 46 | CookieStore 47 | { requestCookies: mempty 48 | , secret: Secret "test" 49 | , responseCookies: Map.empty 50 | } 51 | 52 | x = 53 | runBaseEffect 54 | $ runSetHeader 55 | $ runHTTPExcept 56 | $ runOnStore cookieStore 57 | $ runInCookieValue (Dual.int) (pure 0) Nothing do 58 | value1 ← Session.fetch (Just ttl) 59 | Session.save ttl (value1 + 1) 60 | value2 ← Session.fetch (Just ttl) 61 | (value1 + 1) `shouldEqual` value2 62 | Effect.Class.liftEffect x 63 | describe "in memory store" do 64 | it "performs sudbsquent updates correctly" do 65 | store ← Effect.Class.liftEffect $ Ref.new Map.empty 66 | let 67 | cookieStore = 68 | CookieStore 69 | { requestCookies: mempty 70 | , secret: Secret "test" 71 | , responseCookies: Map.empty 72 | } 73 | 74 | x = 75 | runBaseEffect 76 | $ runSetHeader 77 | $ runHTTPExcept 78 | $ runOnStore cookieStore 79 | $ runInMemoryStore store 0 Nothing do 80 | value1 ← Session.fetch (Just ttl) 81 | Session.save ttl (value1 + 1) 82 | value2 ← Session.fetch (Just ttl) 83 | (value1 + 1) `shouldEqual` value2 84 | Effect.Class.liftEffect x 85 | --------------------------------------------------------------------------------