├── .gitignore ├── .travis.yml ├── CONTRIBUTORS.md ├── PROJECTS.md ├── README.md ├── proj-web ├── .dir-locals.el ├── .gitignore ├── Makefile ├── README.md ├── app │ ├── devel.hs │ └── main.hs ├── config │ ├── example-settings.yml │ ├── favicon.ico │ ├── keter.yml │ ├── robots.txt │ ├── routes │ └── test-settings.yml ├── package.yaml ├── src │ ├── Application.hs │ ├── DevelMain.hs │ ├── Foundation.hs │ ├── Handler │ │ ├── Common.hs │ │ ├── Home.hs │ │ └── Profile.hs │ ├── Import.hs │ ├── Import │ │ └── NoFoundation.hs │ ├── Settings.hs │ └── Settings │ │ └── StaticFiles.hs ├── static │ ├── css │ │ └── bootstrap.css │ └── fonts │ │ ├── glyphicons-halflings-regular.eot │ │ ├── glyphicons-halflings-regular.svg │ │ ├── glyphicons-halflings-regular.ttf │ │ └── glyphicons-halflings-regular.woff ├── templates │ ├── default-layout-wrapper.hamlet │ ├── default-layout.hamlet │ ├── default-layout.lucius │ ├── homepage.hamlet │ ├── homepage.lucius │ ├── profile.hamlet │ └── profile │ │ └── edit.hamlet └── test │ ├── Handler │ ├── CommonSpec.hs │ └── HomeSpec.hs │ ├── Spec.hs │ └── TestImport.hs ├── proj ├── .gitignore ├── ChangeLog.md ├── LICENSE ├── README.md ├── Setup.hs ├── package.yaml ├── src │ ├── Proj.hs │ └── Proj │ │ ├── Models.hs │ │ └── Models │ │ └── Profile.hs └── test │ └── Spec.hs └── stack.yaml /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | .cabal-sandbox/ 3 | cabal.sandbox.config 4 | .stack-work/ 5 | tarballs/ 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This is the simple Travis configuration, which is intended for use 2 | # on applications which do not require cross-platform and 3 | # multiple-GHC-version support. For more information and other 4 | # options, see: 5 | # 6 | # https://docs.haskellstack.org/en/stable/travis_ci/ 7 | # 8 | # Copy these contents into the root directory of your Github project in a file 9 | # named .travis.yml 10 | 11 | # Use new container infrastructure to enable caching 12 | sudo: false 13 | 14 | # Do not choose a language; we provide our own build tools. 15 | language: generic 16 | 17 | # Caching so the next build will be fast too. 18 | cache: 19 | directories: 20 | - $HOME/.stack 21 | 22 | # Ensure necessary system libraries are present 23 | addons: 24 | apt: 25 | packages: 26 | - libgmp-dev 27 | - postgresql-server-dev-all 28 | - postgresql-client 29 | 30 | services: 31 | - postgresql 32 | 33 | before_install: 34 | # Download and unpack the stack executable 35 | - mkdir -p ~/.local/bin 36 | - export PATH=$HOME/.local/bin:$PATH 37 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 38 | 39 | install: 40 | # Build dependencies 41 | - stack --no-terminal --install-ghc test --only-dependencies 42 | - echo "CREATE USER \"proj-web\" WITH PASSWORD 'proj-web';" | psql postgres 43 | - createdb --owner proj-web proj-web_test 44 | - cp proj-web/config/example-settings.yml proj-web/config/settings.yml 45 | 46 | script: 47 | # Build the package, its tests, and its docs and run the tests 48 | - stack --no-terminal test --haddock --no-haddock-deps 49 | -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | # Contributors 2 | 3 | - Matthew Parsons 4 | -------------------------------------------------------------------------------- /PROJECTS.md: -------------------------------------------------------------------------------- 1 | # Haskell Projects 2 | 3 | While `haskell-projects` is working on constructing a nice web application and interface for sharing this information, this file serves as a primitive stand in. 4 | If you have a Haskell project idea, feel free to make a PR and include it in this file! 5 | 6 | # Template 7 | 8 | ## Project Name 9 | 10 | ### Description 11 | 12 | Write a short description of the project. 13 | What does it do? What need does it satisfy? 14 | Is it a library? 15 | Is it a brand new project idea, or a library that needs a new feature? 16 | 17 | ### Mentorship Offered 18 | 19 | What mentorship are you willing to offer on this? 20 | 21 | ### Contact Information 22 | 23 | Include a link or email address for further information. 24 | 25 | # Projects! 26 | 27 | ## Haskell Projects 28 | 29 | ### Description 30 | 31 | `haskell-projects` is a web application that connects mentors and learners to work on real Haskell projects. 32 | Do you want a thing to exist in the Haskell ecosystem? 33 | Make it a project idea! 34 | Do you want to help people learn Haskell? 35 | Pick projects to mentor! 36 | Do you want to learn how to build things in Haskell with guided mentorship? 37 | Find a project and start working on it! 38 | 39 | ### Mentorship Offered 40 | 41 | I (Matt Parsons) am currently sketching out the initial design and implementation. 42 | Once it is minimally done, I will shift gears and start writing issues for feature requests. 43 | If you would like to help, pick an issue and implement it! 44 | 45 | I will be happy to talk through problems thoroughly and provide advice on implementations. 46 | I'm also happy to pair program via Hangouts if that's helpful. 47 | If you're in Denver, we can cowork on it is as well. 48 | 49 | ### Contact Information 50 | 51 | Make an issue on the repo, or send me an email (parsonsmatt@gmail.com) 52 | 53 | ## Haskell Tips and Tricks 54 | 55 | ### Description 56 | 57 | A website where people can submit small tips and tricks, vote on their usefulness, and provide comments. 58 | 59 | ### Mentorship Offered 60 | 61 | I'm (Matt Parsons) happy to help design and implement the application. 62 | I suspect that an MVP would be a very simple website with database connection. 63 | 64 | ### Contact Information 65 | 66 | Send me an email (parsonsmatt@gmail.com) 67 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # `haskell-projects` 2 | 3 | [![Build Status](https://travis-ci.org/haskademy/haskell-projects.svg?branch=master)](https://travis-ci.org/haskademy/haskell-projects) 4 | 5 | A tutorial Haskell project for connecting potential Haskell projects, mentors, and learners. 6 | 7 | ## Where are the projects? 8 | 9 | Until the webapp is actually implemented, check out [PROJECTS.md](./PROJECTS.md) for a listing of projects and mentors. 10 | If you'd like to add one, make a comment in there! 11 | 12 | ## `proj` 13 | 14 | This package contains database models and business logic for the project. 15 | 16 | ## `proj-web` 17 | 18 | This package contains a web front end to access the data. 19 | -------------------------------------------------------------------------------- /proj-web/.dir-locals.el: -------------------------------------------------------------------------------- 1 | ((haskell-mode . ((haskell-indent-spaces . 4) 2 | (haskell-process-use-ghci . t))) 3 | (hamlet-mode . ((hamlet/basic-offset . 4) 4 | (haskell-process-use-ghci . t)))) 5 | -------------------------------------------------------------------------------- /proj-web/.gitignore: -------------------------------------------------------------------------------- 1 | dist* 2 | static/tmp/ 3 | static/combined/ 4 | config/client_session_key.aes 5 | *.hi 6 | *.o 7 | *.sqlite3 8 | *.sqlite3-shm 9 | *.sqlite3-wal 10 | .hsenv* 11 | cabal-dev/ 12 | .stack-work/ 13 | yesod-devel/ 14 | .cabal-sandbox 15 | cabal.sandbox.config 16 | .DS_Store 17 | *.swp 18 | *.keter 19 | *~ 20 | \#* 21 | proj-web.cabal 22 | config/settings.yml 23 | -------------------------------------------------------------------------------- /proj-web/Makefile: -------------------------------------------------------------------------------- 1 | ghcid-devel: 2 | ghcid --command "stack ghci proj-web --flag proj-web:dev" --test "DevelMain.update" 3 | 4 | .PHONY: ghcid-devel 5 | -------------------------------------------------------------------------------- /proj-web/README.md: -------------------------------------------------------------------------------- 1 | # `proj-web` 2 | 3 | The web front-end for `haskell-projects`. 4 | 5 | ## Database Setup 6 | 7 | After installing Postgres, run: 8 | 9 | ``` 10 | $ createuser proj-web --password --superuser 11 | [enter the password proj-web] 12 | $ createdb proj-web 13 | $ createdb proj-web_test 14 | ``` 15 | 16 | ## Haskell Setup 17 | 18 | 1. If you haven't already, [install Stack](https://haskell-lang.org/get-started) 19 | * On POSIX systems, this is usually `curl -sSL https://get.haskellstack.org/ | sh` 20 | 2. Install the `yesod` command line tool: `stack install yesod-bin --install-ghc` 21 | 3. Build libraries: `stack build` 22 | 23 | If you have trouble, refer to the [Yesod Quickstart guide](https://www.yesodweb.com/page/quickstart) for additional detail. 24 | 25 | ## Development 26 | 27 | Start a development server with: 28 | 29 | ``` 30 | stack exec -- yesod devel 31 | ``` 32 | 33 | As your code changes, your site will be automatically be recompiled and redeployed to localhost. 34 | 35 | ## Tests 36 | 37 | ``` 38 | stack test --flag proj-web:library-only --flag proj-web:dev 39 | ``` 40 | 41 | (Because `yesod devel` passes the `library-only` and `dev` flags, matching those flags means you don't need to recompile between tests and development, and it disables optimization to speed up your test compile times). 42 | 43 | ## Documentation 44 | 45 | * Read the [Yesod Book](https://www.yesodweb.com/book) online for free 46 | * Check [Stackage](http://stackage.org/) for documentation on the packages in your LTS Haskell version, or [search it using Hoogle](https://www.stackage.org/lts/hoogle?q=). Tip: Your LTS version is in your `stack.yaml` file. 47 | * For local documentation, use: 48 | * `stack haddock --open` to generate Haddock documentation for your dependencies, and open that documentation in a browser 49 | * `stack hoogle ` to generate a Hoogle database and search for your query 50 | * The [Yesod cookbook](https://github.com/yesodweb/yesod-cookbook) has sample code for various needs 51 | 52 | ## Getting Help 53 | 54 | * Ask questions on [Stack Overflow, using the Yesod or Haskell tags](https://stackoverflow.com/questions/tagged/yesod+haskell) 55 | * Ask the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb) 56 | * There are several chatrooms you can ask for help: 57 | * For IRC, try Freenode#yesod and Freenode#haskell 58 | * [Functional Programming Slack](https://fpchat-invite.herokuapp.com/), in the #haskell, #haskell-beginners, or #yesod channels. 59 | -------------------------------------------------------------------------------- /proj-web/app/devel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | import "proj-web" Application (develMain) 3 | import Prelude (IO) 4 | 5 | main :: IO () 6 | main = develMain 7 | -------------------------------------------------------------------------------- /proj-web/app/main.hs: -------------------------------------------------------------------------------- 1 | import Prelude (IO) 2 | import Application (appMain) 3 | 4 | main :: IO () 5 | main = appMain 6 | -------------------------------------------------------------------------------- /proj-web/config/example-settings.yml: -------------------------------------------------------------------------------- 1 | # Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable. 2 | # See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables 3 | 4 | static-dir: "_env:STATIC_DIR:static" 5 | host: "_env:HOST:*4" # any IPv4 host 6 | port: "_env:PORT:3000" # NB: The port `yesod devel` uses is distinct from this value. Set the `yesod devel` port from the command line. 7 | ip-from-header: "_env:IP_FROM_HEADER:false" 8 | 9 | # Default behavior: determine the application root from the request headers. 10 | # Uncomment to set an explicit approot 11 | #approot: "_env:APPROOT:http://localhost:3000" 12 | 13 | # By default, `yesod devel` runs in development, and built executables use 14 | # production settings (see below). To override this, use the following: 15 | # 16 | # development: false 17 | 18 | # Optional values with the following production defaults. 19 | # In development, they default to the inverse. 20 | # 21 | # detailed-logging: false 22 | # should-log-all: false 23 | # reload-templates: false 24 | # mutable-static: false 25 | # skip-combining: false 26 | # auth-dummy-login : false 27 | 28 | # NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'") 29 | # See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings 30 | 31 | database: 32 | user: "_env:PGUSER:proj-web" 33 | password: "_env:PGPASS:proj-web" 34 | host: "_env:PGHOST:localhost" 35 | port: "_env:PGPORT:5432" 36 | # See config/test-settings.yml for an override during tests 37 | database: "_env:PGDATABASE:proj-web" 38 | poolsize: "_env:PGPOOLSIZE:10" 39 | 40 | copyright: Insert copyright statement here 41 | 42 | github-secret: "_env:HASKPROJ_GITHUB_SECRET:nope" 43 | github-client-id: "_env:HASKPROJ_GITHUB_CLIENT_ID:nope" 44 | -------------------------------------------------------------------------------- /proj-web/config/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskademy/haskell-projects/47c88ffda5d469db7e8596b951b9526ea7090be9/proj-web/config/favicon.ico -------------------------------------------------------------------------------- /proj-web/config/keter.yml: -------------------------------------------------------------------------------- 1 | # After you've edited this file, remove the following line to allow 2 | # `yesod keter` to build your bundle. 3 | user-edited: false 4 | 5 | # A Keter app is composed of 1 or more stanzas. The main stanza will define our 6 | # web application. See the Keter documentation for more information on 7 | # available stanzas. 8 | stanzas: 9 | 10 | # Your Yesod application. 11 | - type: webapp 12 | 13 | # Name of your executable. You are unlikely to need to change this. 14 | # Note that all file paths are relative to the keter.yml file. 15 | # 16 | # The path given is for Stack projects. If you're still using cabal, change 17 | # to 18 | # exec: ../dist/build/proj-web/proj-web 19 | exec: ../dist/bin/proj-web 20 | 21 | # Command line options passed to your application. 22 | args: [] 23 | 24 | hosts: 25 | # You can specify one or more hostnames for your application to respond 26 | # to. The primary hostname will be used for generating your application 27 | # root. 28 | - www.proj-web.com 29 | 30 | # Enable to force Keter to redirect to https 31 | # Can be added to any stanza 32 | requires-secure: false 33 | 34 | # Static files. 35 | - type: static-files 36 | hosts: 37 | - static.proj-web.com 38 | root: ../static 39 | 40 | # Uncomment to turn on directory listings. 41 | # directory-listing: true 42 | 43 | # Redirect plain domain name to www. 44 | - type: redirect 45 | 46 | hosts: 47 | - proj-web.com 48 | actions: 49 | - host: www.proj-web.com 50 | # secure: false 51 | # port: 80 52 | 53 | # Uncomment to switch to a non-permanent redirect. 54 | # status: 303 55 | 56 | # Use the following to automatically copy your bundle upon creation via `yesod 57 | # keter`. Uses `scp` internally, so you can set it to a remote destination 58 | # copy-to: user@host:/opt/keter/incoming/ 59 | 60 | # You can pass arguments to `scp` used above. This example limits bandwidth to 61 | # 1024 Kbit/s and uses port 2222 instead of the default 22 62 | # copy-to-args: 63 | # - "-l 1024" 64 | # - "-P 2222" 65 | 66 | # If you would like to have Keter automatically create a PostgreSQL database 67 | # and set appropriate environment variables for it to be discovered, uncomment 68 | # the following line. 69 | # plugins: 70 | # postgres: true 71 | -------------------------------------------------------------------------------- /proj-web/config/robots.txt: -------------------------------------------------------------------------------- 1 | User-agent: * 2 | -------------------------------------------------------------------------------- /proj-web/config/routes: -------------------------------------------------------------------------------- 1 | -- By default this file is used by `parseRoutesFile` in Foundation.hs 2 | -- Syntax for this file here: https://www.yesodweb.com/book/routing-and-handlers 3 | 4 | /static StaticR Static appStatic 5 | /auth AuthR Auth getAuth 6 | 7 | /favicon.ico FaviconR GET 8 | /robots.txt RobotsR GET 9 | 10 | / HomeR GET 11 | 12 | -- user management pages 13 | /profile ProfileR: 14 | / IndexProfileR GET 15 | /edit EditProfileR GET POST 16 | -------------------------------------------------------------------------------- /proj-web/config/test-settings.yml: -------------------------------------------------------------------------------- 1 | database: 2 | # NOTE: By design, this setting prevents the PGDATABASE environment variable 3 | # from affecting test runs, so that we don't accidentally affect the 4 | # production database during testing. If you're not concerned about that and 5 | # would like to have environment variable overrides, you could instead use 6 | # something like: 7 | # 8 | # database: "_env:PGDATABASE:proj-web_test" 9 | database: proj-web_test 10 | 11 | auth-dummy-login: true 12 | -------------------------------------------------------------------------------- /proj-web/package.yaml: -------------------------------------------------------------------------------- 1 | name: proj-web 2 | version: "0.0.0" 3 | 4 | dependencies: 5 | 6 | # Due to a bug in GHC 8.0.1, we block its usage 7 | # See: https://ghc.haskell.org/trac/ghc/ticket/12130 8 | - base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 9 | 10 | # version 1.0 had a bug in reexporting Handler, causing trouble 11 | - classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1 12 | 13 | - aeson >=0.6 && <1.3 14 | - bytestring >=0.9 && <0.11 15 | - case-insensitive 16 | - classy-prelude >=0.10.2 17 | - classy-prelude-conduit >=0.10.2 18 | - conduit >=1.0 && <2.0 19 | - containers 20 | - data-default 21 | - directory >=1.1 && <1.4 22 | - fast-logger >=2.2 && <2.5 23 | - file-embed 24 | - foreign-store 25 | - hjsmin >=0.1 && <0.3 26 | - http-conduit >=2.1 && <2.3 27 | - monad-control >=0.3 && <1.1 28 | - monad-logger >=0.3 && <0.4 29 | - persistent >=2.0 && <2.8 30 | - persistent-postgresql >=2.1.1 && <2.8 31 | - persistent-template >=2.0 && <2.8 32 | - proj 33 | - safe 34 | - shakespeare >=2.0 && <2.1 35 | - template-haskell 36 | - text >=0.11 && <2.0 37 | - time 38 | - unordered-containers 39 | - vector 40 | - wai 41 | - wai-extra >=3.0 && <3.1 42 | - wai-logger >=2.2 && <2.4 43 | - warp >=3.0 && <3.3 44 | - yaml >=0.8 && <0.9 45 | - yesod >=1.4.3 && <1.5 46 | - yesod-auth >=1.4.0 && <1.5 47 | - yesod-auth-oauth2 48 | - yesod-core >=1.4.30 && <1.5 49 | - yesod-form >=1.4.0 && <1.5 50 | - yesod-static >=1.4.0.3 && <1.6 51 | - lens-aeson 52 | - lens 53 | - blaze-html 54 | 55 | # The library contains all of our application code. The executable 56 | # defined below is just a thin wrapper. 57 | library: 58 | source-dirs: src 59 | when: 60 | - condition: (flag(dev)) || (flag(library-only)) 61 | then: 62 | ghc-options: 63 | - -Wall 64 | - -fwarn-tabs 65 | - -O0 66 | cpp-options: -DDEVELOPMENT 67 | else: 68 | ghc-options: 69 | - -Wall 70 | - -fwarn-tabs 71 | - -O2 72 | 73 | # Runnable executable for our application 74 | executables: 75 | proj-web: 76 | main: main.hs 77 | source-dirs: app 78 | ghc-options: 79 | - -threaded 80 | - -rtsopts 81 | - -with-rtsopts=-N 82 | dependencies: 83 | - proj-web 84 | when: 85 | - condition: flag(library-only) 86 | buildable: false 87 | 88 | # Test suite 89 | tests: 90 | test: 91 | main: Spec.hs 92 | source-dirs: test 93 | ghc-options: -Wall 94 | dependencies: 95 | - proj-web 96 | - hspec >=2.0.0 97 | - yesod-test 98 | 99 | # Define flags used by "yesod devel" to make compilation faster 100 | flags: 101 | library-only: 102 | description: Build for use with "yesod devel" 103 | manual: false 104 | default: false 105 | dev: 106 | description: Turn on development settings, like auto-reload templates. 107 | manual: false 108 | default: false 109 | -------------------------------------------------------------------------------- /proj-web/src/Application.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | 9 | module Application 10 | ( getApplicationDev 11 | , appMain 12 | , develMain 13 | , makeFoundation 14 | , makeLogWare 15 | -- * for DevelMain 16 | , getApplicationRepl 17 | , shutdownApp 18 | -- * for GHCI 19 | , handler 20 | , db 21 | ) where 22 | 23 | import Control.Monad.Logger (liftLoc, runLoggingT) 24 | import Database.Persist.Postgresql (createPostgresqlPool, 25 | pgConnStr, pgPoolSize, 26 | runSqlPool) 27 | import Import 28 | import Language.Haskell.TH.Syntax (qLocation) 29 | import Network.Wai (Middleware) 30 | import Network.Wai.Handler.Warp (Settings, 31 | defaultSettings, 32 | defaultShouldDisplayException, 33 | getPort, runSettings, 34 | setHost, setOnException, 35 | setPort) 36 | import Network.Wai.Middleware.RequestLogger (Destination (Logger), 37 | IPAddrSource (..), 38 | OutputFormat (..), 39 | destination, 40 | mkRequestLogger, 41 | outputFormat) 42 | import System.Log.FastLogger (defaultBufSize, 43 | newStdoutLoggerSet, 44 | toLogStr) 45 | 46 | import Proj.Models (migrateAll) 47 | 48 | -- Import all relevant handler modules here. 49 | -- Don't forget to add new modules to your cabal file! 50 | import Handler.Common 51 | import Handler.Home 52 | import Handler.Profile 53 | 54 | 55 | -- This line actually creates our YesodDispatch instance. It is the second half 56 | -- of the call to mkYesodData which occurs in Foundation.hs. Please see the 57 | -- comments there for more details. 58 | mkYesodDispatch "App" resourcesApp 59 | 60 | -- | This function allocates resources (such as a database connection pool), 61 | -- performs initialization and returns a foundation datatype value. This is also 62 | -- the place to put your migrate statements to have automatic database 63 | -- migrations handled by Yesod. 64 | makeFoundation :: AppSettings -> IO App 65 | makeFoundation appSettings = do 66 | -- Some basic initializations: HTTP connection manager, logger, and static 67 | -- subsite. 68 | appHttpManager <- newManager 69 | appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger 70 | appStatic <- 71 | (if appMutableStatic appSettings then staticDevel else static) 72 | (appStaticDir appSettings) 73 | 74 | -- We need a log function to create a connection pool. We need a connection 75 | -- pool to create our foundation. And we need our foundation to get a 76 | -- logging function. To get out of this loop, we initially create a 77 | -- temporary foundation without a real connection pool, get a log function 78 | -- from there, and then create the real foundation. 79 | let mkFoundation appConnPool = App {..} 80 | -- The App {..} syntax is an example of record wild cards. For more 81 | -- information, see: 82 | -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html 83 | tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" 84 | logFunc = messageLoggerSource tempFoundation appLogger 85 | 86 | -- Create the database connection pool 87 | pool <- flip runLoggingT logFunc $ createPostgresqlPool 88 | (pgConnStr $ appDatabaseConf appSettings) 89 | (pgPoolSize $ appDatabaseConf appSettings) 90 | 91 | -- Perform database migration using our application's logging settings. 92 | runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc 93 | 94 | -- Return the foundation 95 | return $ mkFoundation pool 96 | 97 | -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and 98 | -- applying some additional middlewares. 99 | makeApplication :: App -> IO Application 100 | makeApplication foundation = do 101 | logWare <- makeLogWare foundation 102 | -- Create the WAI application and apply middlewares 103 | appPlain <- toWaiAppPlain foundation 104 | return $ logWare $ defaultMiddlewaresNoLogging appPlain 105 | 106 | makeLogWare :: App -> IO Middleware 107 | makeLogWare foundation = 108 | mkRequestLogger def 109 | { outputFormat = 110 | if appDetailedRequestLogging $ appSettings foundation 111 | then Detailed True 112 | else Apache 113 | (if appIpFromHeader $ appSettings foundation 114 | then FromFallback 115 | else FromSocket) 116 | , destination = Logger $ loggerSet $ appLogger foundation 117 | } 118 | 119 | 120 | -- | Warp settings for the given foundation value. 121 | warpSettings :: App -> Settings 122 | warpSettings foundation = 123 | setPort (appPort $ appSettings foundation) 124 | $ setHost (appHost $ appSettings foundation) 125 | $ setOnException (\_req e -> 126 | when (defaultShouldDisplayException e) $ messageLoggerSource 127 | foundation 128 | (appLogger foundation) 129 | $(qLocation >>= liftLoc) 130 | "yesod" 131 | LevelError 132 | (toLogStr $ "Exception from Warp: " ++ show e)) 133 | defaultSettings 134 | 135 | -- | For yesod devel, return the Warp settings and WAI Application. 136 | getApplicationDev :: IO (Settings, Application) 137 | getApplicationDev = do 138 | settings <- getAppSettings 139 | foundation <- makeFoundation settings 140 | wsettings <- getDevSettings $ warpSettings foundation 141 | app <- makeApplication foundation 142 | return (wsettings, app) 143 | 144 | getAppSettings :: IO AppSettings 145 | getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv 146 | 147 | -- | main function for use by yesod devel 148 | develMain :: IO () 149 | develMain = develMainHelper getApplicationDev 150 | 151 | -- | The @main@ function for an executable running this site. 152 | appMain :: IO () 153 | appMain = do 154 | -- Get the settings from all relevant sources 155 | settings <- loadYamlSettingsArgs 156 | -- fall back to compile-time values, set to [] to require values at runtime 157 | [configSettingsYmlValue] 158 | 159 | -- allow environment variables to override 160 | useEnv 161 | 162 | -- Generate the foundation from the settings 163 | foundation <- makeFoundation settings 164 | 165 | -- Generate a WAI Application from the foundation 166 | app <- makeApplication foundation 167 | 168 | -- Run the application with Warp 169 | runSettings (warpSettings foundation) app 170 | 171 | 172 | -------------------------------------------------------------- 173 | -- Functions for DevelMain.hs (a way to run the app from GHCi) 174 | -------------------------------------------------------------- 175 | getApplicationRepl :: IO (Int, App, Application) 176 | getApplicationRepl = do 177 | settings <- getAppSettings 178 | foundation <- makeFoundation settings 179 | wsettings <- getDevSettings $ warpSettings foundation 180 | app1 <- makeApplication foundation 181 | return (getPort wsettings, foundation, app1) 182 | 183 | shutdownApp :: App -> IO () 184 | shutdownApp _ = return () 185 | 186 | 187 | --------------------------------------------- 188 | -- Functions for use in development with GHCi 189 | --------------------------------------------- 190 | 191 | -- | Run a handler 192 | handler :: Handler a -> IO a 193 | handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h 194 | 195 | -- | Run DB queries 196 | db :: ReaderT SqlBackend (HandlerT App IO) a -> IO a 197 | db = handler . runDB 198 | -------------------------------------------------------------------------------- /proj-web/src/DevelMain.hs: -------------------------------------------------------------------------------- 1 | -- | Running your app inside GHCi. 2 | -- 3 | -- To start up GHCi for usage with Yesod, first make sure you are in dev mode: 4 | -- 5 | -- > cabal configure -fdev 6 | -- 7 | -- Note that @yesod devel@ automatically sets the dev flag. 8 | -- Now launch the repl: 9 | -- 10 | -- > cabal repl --ghc-options="-O0 -fobject-code" 11 | -- 12 | -- To start your app, run: 13 | -- 14 | -- > :l DevelMain 15 | -- > DevelMain.update 16 | -- 17 | -- You can also call @DevelMain.shutdown@ to stop the app 18 | -- 19 | -- You will need to add the foreign-store package to your .cabal file. 20 | -- It is very light-weight. 21 | -- 22 | -- If you don't use cabal repl, you will need 23 | -- to run the following in GHCi or to add it to 24 | -- your .ghci file. 25 | -- 26 | -- :set -DDEVELOPMENT 27 | -- 28 | -- There is more information about this approach, 29 | -- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci 30 | 31 | module DevelMain where 32 | 33 | import Prelude 34 | import Application (getApplicationRepl, shutdownApp) 35 | 36 | import Control.Exception (finally) 37 | import Control.Monad ((>=>)) 38 | import Control.Concurrent 39 | import Data.IORef 40 | import Foreign.Store 41 | import Network.Wai.Handler.Warp 42 | import GHC.Word 43 | 44 | -- | Start or restart the server. 45 | -- newStore is from foreign-store. 46 | -- A Store holds onto some data across ghci reloads 47 | update :: IO () 48 | update = do 49 | mtidStore <- lookupStore tidStoreNum 50 | case mtidStore of 51 | -- no server running 52 | Nothing -> do 53 | done <- storeAction doneStore newEmptyMVar 54 | tid <- start done 55 | _ <- storeAction (Store tidStoreNum) (newIORef tid) 56 | return () 57 | -- server is already running 58 | Just tidStore -> restartAppInNewThread tidStore 59 | where 60 | doneStore :: Store (MVar ()) 61 | doneStore = Store 0 62 | 63 | -- shut the server down with killThread and wait for the done signal 64 | restartAppInNewThread :: Store (IORef ThreadId) -> IO () 65 | restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do 66 | killThread tid 67 | withStore doneStore takeMVar 68 | readStore doneStore >>= start 69 | 70 | 71 | -- | Start the server in a separate thread. 72 | start :: MVar () -- ^ Written to when the thread is killed. 73 | -> IO ThreadId 74 | start done = do 75 | (port, site, app) <- getApplicationRepl 76 | forkIO (finally (runSettings (setPort port defaultSettings) app) 77 | -- Note that this implies concurrency 78 | -- between shutdownApp and the next app that is starting. 79 | -- Normally this should be fine 80 | (putMVar done () >> shutdownApp site)) 81 | 82 | -- | kill the server 83 | shutdown :: IO () 84 | shutdown = do 85 | mtidStore <- lookupStore tidStoreNum 86 | case mtidStore of 87 | -- no server running 88 | Nothing -> putStrLn "no Yesod app running" 89 | Just tidStore -> do 90 | withStore tidStore $ readIORef >=> killThread 91 | putStrLn "Yesod app is shutdown" 92 | 93 | tidStoreNum :: Word32 94 | tidStoreNum = 1 95 | 96 | modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO () 97 | modifyStoredIORef store f = withStore store $ \ref -> do 98 | v <- readIORef ref 99 | f v >>= writeIORef ref 100 | -------------------------------------------------------------------------------- /proj-web/src/Foundation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ExplicitForAll #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | 11 | module Foundation where 12 | 13 | import Import.NoFoundation 14 | 15 | import Control.Lens 16 | import Data.Aeson.Lens 17 | import qualified Data.CaseInsensitive as CI 18 | import qualified Data.Text.Encoding as TE 19 | import Database.Persist.Sql 20 | import Text.Hamlet (hamletFile) 21 | import Text.Jasmine (minifym) 22 | import Yesod.Auth.Dummy 23 | import Yesod.Auth.OAuth2 (getUserResponse) 24 | import Yesod.Auth.OAuth2.Github 25 | import Yesod.Core.Types (Logger) 26 | import qualified Yesod.Core.Unsafe as Unsafe 27 | import Yesod.Default.Util (addStaticContentExternal) 28 | 29 | import Proj.Models 30 | 31 | -- | The foundation datatype for your application. This can be a good place to 32 | -- keep settings and values requiring initialization before your application 33 | -- starts running, such as database connections. Every handler will have 34 | -- access to the data present here. 35 | data App = App 36 | { appSettings :: AppSettings 37 | , appStatic :: Static -- ^ Settings for static file serving. 38 | , appConnPool :: ConnectionPool -- ^ Database connection pool. 39 | , appHttpManager :: Manager 40 | , appLogger :: Logger 41 | } 42 | 43 | data MenuItem = MenuItem 44 | { menuItemLabel :: Text 45 | , menuItemRoute :: Route App 46 | , menuItemAccessCallback :: Bool 47 | } 48 | 49 | data MenuTypes 50 | = NavbarLeft MenuItem 51 | | NavbarRight MenuItem 52 | 53 | -- This is where we define all of the routes in our application. For a full 54 | -- explanation of the syntax, please see: 55 | -- http://www.yesodweb.com/book/routing-and-handlers 56 | -- 57 | -- Note that this is really half the story; in Application.hs, mkYesodDispatch 58 | -- generates the rest of the code. Please see the following documentation 59 | -- for an explanation for this split: 60 | -- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules 61 | -- 62 | -- This function also generates the following type synonyms: 63 | -- type Handler = HandlerT App IO 64 | -- type Widget = WidgetT App IO () 65 | mkYesodData "App" $ $(parseRoutesFile "config/routes") 66 | 67 | -- | A convenient synonym for creating forms. 68 | type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget) 69 | 70 | -- | A convenient synonym for database access functions. 71 | type DB a = forall (m :: * -> *). 72 | (MonadIO m, Functor m) => ReaderT SqlBackend m a 73 | 74 | -- Please see the documentation for the Yesod typeclass. There are a number 75 | -- of settings which can be configured by overriding methods here. 76 | instance Yesod App where 77 | -- Controls the base of generated URLs. For more information on modifying, 78 | -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot 79 | approot = ApprootRequest $ \app req -> 80 | fromMaybe (getApprootText guessApproot app req) $ appRoot (appSettings app) 81 | 82 | -- Store session data on the client in encrypted cookies, 83 | -- default session idle timeout is 120 minutes 84 | makeSessionBackend _ = Just <$> defaultClientSessionBackend 85 | 120 -- timeout in minutes 86 | "config/client_session_key.aes" 87 | 88 | -- Yesod Middleware allows you to run code before and after each handler function. 89 | -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. 90 | -- Some users may also want to add the defaultCsrfMiddleware, which: 91 | -- a) Sets a cookie with a CSRF token in it. 92 | -- b) Validates that incoming write requests include that token in either a header or POST parameter. 93 | -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware 94 | -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. 95 | yesodMiddleware = defaultYesodMiddleware 96 | 97 | defaultLayout widget = do 98 | master <- getYesod 99 | mmsg <- getMessage 100 | 101 | muser <- maybeAuthPair 102 | mcurrentRoute <- getCurrentRoute 103 | 104 | -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. 105 | (title, parents) <- breadcrumbs 106 | 107 | -- Define the menu items of the header. 108 | let menuItems = 109 | [ NavbarLeft MenuItem 110 | { menuItemLabel = "Home" 111 | , menuItemRoute = HomeR 112 | , menuItemAccessCallback = True 113 | } 114 | , NavbarLeft MenuItem 115 | { menuItemLabel = "Profile" 116 | , menuItemRoute = ProfileR IndexProfileR 117 | , menuItemAccessCallback = isJust muser 118 | } 119 | , NavbarRight MenuItem 120 | { menuItemLabel = "Login" 121 | , menuItemRoute = AuthR LoginR 122 | , menuItemAccessCallback = isNothing muser 123 | } 124 | , NavbarRight MenuItem 125 | { menuItemLabel = "Logout" 126 | , menuItemRoute = AuthR LogoutR 127 | , menuItemAccessCallback = isJust muser 128 | } 129 | ] 130 | 131 | let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems] 132 | let navbarRightMenuItems = [x | NavbarRight x <- menuItems] 133 | 134 | let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x] 135 | let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x] 136 | 137 | -- We break up the default layout into two components: 138 | -- default-layout is the contents of the body tag, and 139 | -- default-layout-wrapper is the entire page. Since the final 140 | -- value passed to hamletToRepHtml cannot be a widget, this allows 141 | -- you to use normal widget features in default-layout. 142 | 143 | pc <- widgetToPageContent $ do 144 | addStylesheet $ StaticR css_bootstrap_css 145 | $(widgetFile "default-layout") 146 | withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") 147 | 148 | -- The page to be redirected to when authentication is required. 149 | authRoute _ = Just (AuthR LoginR) 150 | 151 | isAuthorized route _isWrite = do 152 | mauth <- maybeAuth 153 | case route of 154 | HomeR -> 155 | return Authorized 156 | FaviconR -> 157 | return Authorized 158 | RobotsR -> 159 | return Authorized 160 | StaticR _ -> 161 | return Authorized 162 | AuthR {} -> 163 | return Authorized 164 | ProfileR {} | isJust mauth -> 165 | return Authorized 166 | _ -> 167 | return $ Unauthorized "You must be authorized to view this page." 168 | 169 | -- This function creates static content files in the static folder 170 | -- and names them based on a hash of their content. This allows 171 | -- expiration dates to be set far in the future without worry of 172 | -- users receiving stale content. 173 | addStaticContent ext mime content = do 174 | master <- getYesod 175 | let staticDir = appStaticDir $ appSettings master 176 | addStaticContentExternal 177 | minifym 178 | genFileName 179 | staticDir 180 | (StaticR . flip StaticRoute []) 181 | ext 182 | mime 183 | content 184 | where 185 | -- Generate a unique filename based on the content itself 186 | genFileName lbs = "autogen-" ++ base64md5 lbs 187 | 188 | -- What messages should be logged. The following includes all messages when 189 | -- in development, and warnings and errors in production. 190 | shouldLog app _source level = 191 | appShouldLogAll (appSettings app) 192 | || level == LevelWarn 193 | || level == LevelError 194 | 195 | makeLogger = return . appLogger 196 | 197 | -- Define breadcrumbs. 198 | instance YesodBreadcrumbs App where 199 | breadcrumb = \case 200 | HomeR -> 201 | return ("Home", Nothing) 202 | ProfileR subroute -> 203 | case subroute of 204 | IndexProfileR -> 205 | return ("Profile", Just HomeR) 206 | EditProfileR -> 207 | return ("Edit", Just (ProfileR IndexProfileR)) 208 | _ -> 209 | return ("Home", Nothing) 210 | 211 | -- How to run database actions. 212 | instance YesodPersist App where 213 | type YesodPersistBackend App = SqlBackend 214 | runDB action = do 215 | master <- getYesod 216 | runSqlPool action $ appConnPool master 217 | 218 | instance YesodPersistRunner App where 219 | getDBRunner = defaultGetDBRunner appConnPool 220 | 221 | instance YesodAuth App where 222 | type AuthId App = UserId 223 | 224 | -- Where to send a user after successful login 225 | loginDest _ = HomeR 226 | -- Where to send a user after logout 227 | logoutDest _ = HomeR 228 | -- Override the above two destinations when a Referer: header is present 229 | redirectToReferer _ = True 230 | 231 | authenticate creds | credsPlugin creds == "github" = do 232 | let muserId = do 233 | resp <- getUserResponse creds 234 | resp ^? _Object . ix "id" . _Integral 235 | 236 | case muserId of 237 | Nothing -> do 238 | $logError $ "No user ID found in auth request: " <> tshow creds 239 | pure (ServerError "The authentication response wasn't quite right.") 240 | Just oauthUserId -> do 241 | mlogin <- runDB $ get (toSqlKey oauthUserId) 242 | case mlogin of 243 | Just oauthLogin -> 244 | pure (Authenticated (oauthLoginUser oauthLogin)) 245 | Nothing -> 246 | runDB $ do 247 | now <- liftIO getCurrentTime 248 | userId <- insert User 249 | { userName = 250 | "Nameless One" 251 | , userCreated = 252 | now 253 | , userUpdated = 254 | now 255 | } 256 | repsert (toSqlKey oauthUserId) OauthLogin 257 | { oauthLoginProvider = 258 | credsPlugin creds 259 | , oauthLoginUser = 260 | userId 261 | } 262 | pure (Authenticated userId) 263 | authenticate creds | credsPlugin creds == "dummy" = do 264 | muser <- runDB $ selectFirst [ UserName ==. credsIdent creds ] [] 265 | case muser of 266 | Nothing -> runDB $ do 267 | now <- liftIO getCurrentTime 268 | userId <- insert User 269 | { userName = credsIdent creds 270 | , userCreated = now 271 | , userUpdated = now 272 | } 273 | _ <- insert OauthLogin 274 | { oauthLoginProvider = 275 | "dummy" 276 | , oauthLoginUser = 277 | userId 278 | } 279 | pure (Authenticated userId) 280 | Just (Entity userId _) -> 281 | pure (Authenticated userId) 282 | authenticate _ = 283 | pure (ServerError "only github and dummy supported") 284 | 285 | -- You can add other plugins like Google Email, email or OAuth here 286 | authPlugins App{..} = 287 | oauth2Github appGithubClientId appGithubSecret 288 | : extraAuthPlugins 289 | -- Enable authDummy login if enabled. 290 | where 291 | extraAuthPlugins = [authDummy | appAuthDummyLogin ] 292 | AppSettings{..} = appSettings 293 | 294 | 295 | authHttpManager = getHttpManager 296 | 297 | instance YesodAuthPersist App 298 | 299 | -- This instance is required to use forms. You can modify renderMessage to 300 | -- achieve customized and internationalized form validation messages. 301 | instance RenderMessage App FormMessage where 302 | renderMessage _ _ = defaultFormMessage 303 | 304 | -- Useful when writing code that is re-usable outside of the Handler context. 305 | -- An example is background jobs that send email. 306 | -- This can also be useful for writing code that works across multiple Yesod applications. 307 | instance HasHttpManager App where 308 | getHttpManager = appHttpManager 309 | 310 | unsafeHandler :: App -> Handler a -> IO a 311 | unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger 312 | 313 | -- Note: Some functionality previously present in the scaffolding has been 314 | -- moved to documentation in the Wiki. Following are some hopefully helpful 315 | -- links: 316 | -- 317 | -- https://github.com/yesodweb/yesod/wiki/Sending-email 318 | -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain 319 | -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding 320 | -- 321 | -------------------------------------------------------------------------------- /proj-web/src/Handler/Common.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | -- | Common handler functions. 7 | module Handler.Common where 8 | 9 | import Data.FileEmbed (embedFile) 10 | import Import 11 | 12 | -- These handlers embed files in the executable at compile time to avoid a 13 | -- runtime dependency, and for efficiency. 14 | 15 | getFaviconR :: Handler TypedContent 16 | getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month 17 | return $ TypedContent "image/x-icon" 18 | $ toContent $(embedFile "config/favicon.ico") 19 | 20 | getRobotsR :: Handler TypedContent 21 | getRobotsR = return $ TypedContent typePlain 22 | $ toContent $(embedFile "config/robots.txt") 23 | -------------------------------------------------------------------------------- /proj-web/src/Handler/Home.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE TemplateHaskell #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | 7 | module Handler.Home where 8 | 9 | import Import 10 | 11 | -- This is a handler function for the GET request method on the HomeR 12 | -- resource pattern. All of your resource patterns are defined in 13 | -- config/routes 14 | -- 15 | -- The majority of the code you will write in Yesod lives in these handler 16 | -- functions. You can spread them across multiple files if you are so 17 | -- inclined, or create a single monolithic file. 18 | getHomeR :: Handler Html 19 | getHomeR = do 20 | defaultLayout $ do 21 | setTitle "Haskell Projects" 22 | $(widgetFile "homepage") 23 | -------------------------------------------------------------------------------- /proj-web/src/Handler/Profile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | 8 | module Handler.Profile where 9 | 10 | import Import 11 | 12 | import Yesod.Form.Bootstrap3 13 | 14 | import Proj.Models 15 | import Proj.Models.Profile 16 | 17 | getIndexProfileR :: Handler Html 18 | getIndexProfileR = do 19 | Entity _ user <- requireAuth 20 | defaultLayout $ do 21 | setTitle "Profile" 22 | $(widgetFile "profile") 23 | 24 | getEditProfileR :: Handler Html 25 | getEditProfileR = do 26 | Entity userId _ <- requireAuth 27 | profile <- maybe notFound pure =<< runDB (selectProfile userId) 28 | ((_, formWidget), enctype) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ profileForm (Just profile) 29 | defaultLayout $ do 30 | setTitle "Edit Profile" 31 | $(widgetFile "profile/edit") 32 | 33 | postEditProfileR :: Handler Html 34 | postEditProfileR = do 35 | Entity userId _ <- requireAuth 36 | -- profile <- maybe notFound pure =<< runDB (selectProfile userId) 37 | ((formResult, formWidget), enctype) <- runFormPost $ renderBootstrap3 BootstrapBasicForm $ profileForm Nothing 38 | 39 | case formResult of 40 | FormSuccess EditProfile {..} -> do 41 | runDB $ do 42 | update userId [UserName =. epName] 43 | if epLearner 44 | then void $ insertUnique (Learner userId) 45 | else deleteWhere [LearnerUser ==. userId] 46 | if epMentor 47 | then void $ insertUnique (Mentor userId) 48 | else deleteWhere [MentorUser ==. userId] 49 | redirect (ProfileR EditProfileR) 50 | _ -> 51 | defaultLayout $ do 52 | setTitle "Edit Profile" 53 | $(widgetFile "profile/edit") 54 | 55 | data EditProfile = EditProfile 56 | { epName :: Text 57 | , epLearner :: Bool 58 | , epMentor :: Bool 59 | } deriving (Eq, Show) 60 | 61 | profileForm :: Maybe Profile -> AForm Handler EditProfile 62 | profileForm mprofile = 63 | EditProfile 64 | <$> areq textField 65 | (bfs (asText "Name: ")) 66 | (fmap (userName . entityVal . profileUser) mprofile) 67 | <*> areq checkBoxField 68 | (bfs (asText "Mentor: ")) 69 | (fmap (isJust . profileMentor) mprofile) 70 | <*> areq checkBoxField 71 | (bfs (asText "Learner: ")) 72 | (fmap (isJust . profileLearner) mprofile) 73 | -------------------------------------------------------------------------------- /proj-web/src/Import.hs: -------------------------------------------------------------------------------- 1 | module Import 2 | ( module Import 3 | ) where 4 | 5 | import Foundation as Import 6 | import Import.NoFoundation as Import 7 | -------------------------------------------------------------------------------- /proj-web/src/Import/NoFoundation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Import.NoFoundation 3 | ( module Import 4 | ) where 5 | 6 | import ClassyPrelude.Yesod as Import 7 | import Settings as Import 8 | import Settings.StaticFiles as Import 9 | import Yesod.Auth as Import 10 | import Yesod.Core.Types as Import (loggerSet) 11 | import Yesod.Default.Config2 as Import 12 | -------------------------------------------------------------------------------- /proj-web/src/Settings.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | -- | Settings are centralized, as much as possible, into this file. This 7 | -- includes database connection settings, static file locations, etc. 8 | -- In addition, you can configure a number of different aspects of Yesod 9 | -- by overriding methods in the Yesod typeclass. That instance is 10 | -- declared in the Foundation.hs file. 11 | module Settings where 12 | 13 | import ClassyPrelude.Yesod 14 | import qualified Control.Exception as Exception 15 | import Data.Aeson (Result (..), fromJSON, withObject, 16 | (.!=), (.:?)) 17 | import Data.FileEmbed (embedFile) 18 | import Data.Yaml (decodeEither') 19 | import Database.Persist.Postgresql (PostgresConf) 20 | import Language.Haskell.TH.Syntax (Exp, Name, Q) 21 | import Network.Wai.Handler.Warp (HostPreference) 22 | import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) 23 | import Yesod.Default.Util (WidgetFileSettings, 24 | widgetFileNoReload, 25 | widgetFileReload) 26 | 27 | -- | Runtime settings to configure this application. These settings can be 28 | -- loaded from various sources: defaults, environment variables, config files, 29 | -- theoretically even a database. 30 | data AppSettings = AppSettings 31 | { appStaticDir :: String 32 | -- ^ Directory from which to serve static files. 33 | , appDatabaseConf :: PostgresConf 34 | -- ^ Configuration settings for accessing the database. 35 | , appRoot :: Maybe Text 36 | -- ^ Base for all generated URLs. If @Nothing@, determined 37 | -- from the request headers. 38 | , appHost :: HostPreference 39 | -- ^ Host/interface the server should bind to. 40 | , appPort :: Int 41 | -- ^ Port to listen on 42 | , appIpFromHeader :: Bool 43 | -- ^ Get the IP address from the header when logging. Useful when sitting 44 | -- behind a reverse proxy. 45 | 46 | , appDetailedRequestLogging :: Bool 47 | -- ^ Use detailed request logging system 48 | , appShouldLogAll :: Bool 49 | -- ^ Should all log messages be displayed? 50 | , appReloadTemplates :: Bool 51 | -- ^ Use the reload version of templates 52 | , appMutableStatic :: Bool 53 | -- ^ Assume that files in the static dir may change after compilation 54 | , appSkipCombining :: Bool 55 | -- ^ Perform no stylesheet/script combining 56 | 57 | -- Example app-specific configuration values. 58 | , appCopyright :: Text 59 | -- ^ Copyright text to appear in the footer of the page 60 | , appAnalytics :: Maybe Text 61 | -- ^ Google Analytics code 62 | 63 | , appAuthDummyLogin :: Bool 64 | -- ^ Indicate if auth dummy login should be enabled. 65 | 66 | , appGithubClientId :: Text 67 | , appGithubSecret :: Text 68 | } 69 | 70 | instance FromJSON AppSettings where 71 | parseJSON = withObject "AppSettings" $ \o -> do 72 | let defaultDev = 73 | #ifdef DEVELOPMENT 74 | True 75 | #else 76 | False 77 | #endif 78 | appStaticDir <- o .: "static-dir" 79 | appDatabaseConf <- o .: "database" 80 | appRoot <- o .:? "approot" 81 | appHost <- fromString <$> o .: "host" 82 | appPort <- o .: "port" 83 | appIpFromHeader <- o .: "ip-from-header" 84 | 85 | dev <- o .:? "development" .!= defaultDev 86 | 87 | appDetailedRequestLogging <- o .:? "detailed-logging" .!= dev 88 | appShouldLogAll <- o .:? "should-log-all" .!= dev 89 | appReloadTemplates <- o .:? "reload-templates" .!= dev 90 | appMutableStatic <- o .:? "mutable-static" .!= dev 91 | appSkipCombining <- o .:? "skip-combining" .!= dev 92 | 93 | appCopyright <- o .: "copyright" 94 | appAnalytics <- o .:? "analytics" 95 | 96 | appAuthDummyLogin <- o .:? "auth-dummy-login" .!= dev 97 | appGithubSecret <- o .:? "github-secret" .!= "" 98 | appGithubClientId <- o .:? "github-client-id" .!= "" 99 | 100 | return AppSettings {..} 101 | 102 | -- | Settings for 'widgetFile', such as which template languages to support and 103 | -- default Hamlet settings. 104 | -- 105 | -- For more information on modifying behavior, see: 106 | -- 107 | -- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile 108 | widgetFileSettings :: WidgetFileSettings 109 | widgetFileSettings = def 110 | 111 | -- | How static files should be combined. 112 | combineSettings :: CombineSettings 113 | combineSettings = def 114 | 115 | -- The rest of this file contains settings which rarely need changing by a 116 | -- user. 117 | 118 | widgetFile :: String -> Q Exp 119 | widgetFile = (if appReloadTemplates compileTimeAppSettings 120 | then widgetFileReload 121 | else widgetFileNoReload) 122 | widgetFileSettings 123 | 124 | -- | Raw bytes at compile time of @config/settings.yml@ 125 | configSettingsYmlBS :: ByteString 126 | configSettingsYmlBS = $(embedFile configSettingsYml) 127 | 128 | -- | @config/settings.yml@, parsed to a @Value@. 129 | configSettingsYmlValue :: Value 130 | configSettingsYmlValue = either Exception.throw id 131 | $ decodeEither' configSettingsYmlBS 132 | 133 | -- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@. 134 | compileTimeAppSettings :: AppSettings 135 | compileTimeAppSettings = 136 | case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of 137 | Error e -> error e 138 | Success settings -> settings 139 | 140 | -- The following two functions can be used to combine multiple CSS or JS files 141 | -- at compile time to decrease the number of http requests. 142 | -- Sample usage (inside a Widget): 143 | -- 144 | -- > $(combineStylesheets 'StaticR [style1_css, style2_css]) 145 | 146 | combineStylesheets :: Name -> [Route Static] -> Q Exp 147 | combineStylesheets = combineStylesheets' 148 | (appSkipCombining compileTimeAppSettings) 149 | combineSettings 150 | 151 | combineScripts :: Name -> [Route Static] -> Q Exp 152 | combineScripts = combineScripts' 153 | (appSkipCombining compileTimeAppSettings) 154 | combineSettings 155 | -------------------------------------------------------------------------------- /proj-web/src/Settings/StaticFiles.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | module Settings.StaticFiles where 5 | 6 | import Settings (appStaticDir, compileTimeAppSettings) 7 | import Yesod.Static (staticFiles) 8 | 9 | -- This generates easy references to files in the static directory at compile time, 10 | -- giving you compile-time verification that referenced files exist. 11 | -- Warning: any files added to your static directory during run-time can't be 12 | -- accessed this way. You'll have to use their FilePath or URL to access them. 13 | -- 14 | -- For example, to refer to @static/js/script.js@ via an identifier, you'd use: 15 | -- 16 | -- js_script_js 17 | -- 18 | -- If the identifier is not available, you may use: 19 | -- 20 | -- StaticFile ["js", "script.js"] [] 21 | staticFiles (appStaticDir compileTimeAppSettings) 22 | -------------------------------------------------------------------------------- /proj-web/static/fonts/glyphicons-halflings-regular.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskademy/haskell-projects/47c88ffda5d469db7e8596b951b9526ea7090be9/proj-web/static/fonts/glyphicons-halflings-regular.eot -------------------------------------------------------------------------------- /proj-web/static/fonts/glyphicons-halflings-regular.svg: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | 146 | 147 | 148 | 149 | 150 | 151 | 152 | 153 | 154 | 155 | 156 | 157 | 158 | 159 | 160 | 161 | 162 | 163 | 164 | 165 | 166 | 167 | 168 | 169 | 170 | 171 | 172 | 173 | 174 | 175 | 176 | 177 | 178 | 179 | 180 | 181 | 182 | 183 | 184 | 185 | 186 | 187 | 188 | 189 | 190 | 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | 199 | 200 | 201 | 202 | 203 | 204 | 205 | 206 | 207 | 208 | 209 | 210 | 211 | 212 | 213 | 214 | 215 | 216 | 217 | 218 | 219 | 220 | 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | -------------------------------------------------------------------------------- /proj-web/static/fonts/glyphicons-halflings-regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskademy/haskell-projects/47c88ffda5d469db7e8596b951b9526ea7090be9/proj-web/static/fonts/glyphicons-halflings-regular.ttf -------------------------------------------------------------------------------- /proj-web/static/fonts/glyphicons-halflings-regular.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/haskademy/haskell-projects/47c88ffda5d469db7e8596b951b9526ea7090be9/proj-web/static/fonts/glyphicons-halflings-regular.woff -------------------------------------------------------------------------------- /proj-web/templates/default-layout-wrapper.hamlet: -------------------------------------------------------------------------------- 1 | $newline never 2 | \ 3 | \ 4 | \ 5 | \ 6 | \ 7 | 8 | 9 | 10 | 11 | #{pageTitle pc} 12 | <meta name="description" content=""> 13 | <meta name="author" content=""> 14 | 15 | <meta name="viewport" content="width=device-width,initial-scale=1"> 16 | 17 | ^{pageHead pc} 18 | 19 | \<!--[if lt IE 9]> 20 | \<script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script> 21 | \<![endif]--> 22 | <script type="text/javascript" src="https://cdnjs.cloudflare.com/ajax/libs/jquery/2.1.4/jquery.js"> 23 | <script type="text/javascript" src="https://cdnjs.cloudflare.com/ajax/libs/js-cookie/2.0.3/js.cookie.min.js"> 24 | 25 | \<!-- Bootstrap-3.3.7 compiled and minified JavaScript --> 26 | <script src="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/js/bootstrap.min.js" integrity="sha384-Tc5IQib027qvyjSMfHjOMaLkfuWVxZxUPnCJA7l2mCWNIpG9mGCD8wGNIcPD7Txa" crossorigin="anonymous"> 27 | 28 | <script> 29 | /* The `defaultCsrfMiddleware` Middleware added in Foundation.hs adds a CSRF token to the request cookies. */ 30 | /* AJAX requests should add that token to a header to be validated by the server. */ 31 | /* See the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package for details. */ 32 | var csrfHeaderName = "#{TE.decodeUtf8 $ CI.foldedCase defaultCsrfHeaderName}"; 33 | 34 | var csrfCookieName = "#{TE.decodeUtf8 defaultCsrfCookieName}"; 35 | var csrfToken = Cookies.get(csrfCookieName); 36 | 37 | 38 | if (csrfToken) { 39 | \ $.ajaxPrefilter(function( options, originalOptions, jqXHR ) { 40 | \ if (!options.crossDomain) { 41 | \ jqXHR.setRequestHeader(csrfHeaderName, csrfToken); 42 | \ } 43 | \ }); 44 | } 45 | 46 | <script> 47 | document.documentElement.className = document.documentElement.className.replace(/\bno-js\b/,'js'); 48 | <body> 49 | ^{pageBody pc} 50 | 51 | $maybe analytics <- appAnalytics $ appSettings master 52 | <script> 53 | if(!window.location.href.match(/localhost/)){ 54 | (function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){ 55 | (i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement(o), 56 | m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.insertBefore(a,m) 57 | })(window,document,'script','https://www.google-analytics.com/analytics.js','ga'); 58 | 59 | ga('create', '#{analytics}', 'auto'); 60 | ga('send', 'pageview'); 61 | } 62 | -------------------------------------------------------------------------------- /proj-web/templates/default-layout.hamlet: -------------------------------------------------------------------------------- 1 | 2 | <!-- Static navbar --> 3 | <nav .navbar.navbar-default.navbar-static-top> 4 | <div .container> 5 | <div .navbar-header> 6 | <button type="button" .navbar-toggle.collapsed data-toggle="collapse" data-target="#navbar" aria-expanded="false" aria-controls="navbar"> 7 | <span class="sr-only">Toggle navigation</span> 8 | <span class="icon-bar"></span> 9 | <span class="icon-bar"></span> 10 | <span class="icon-bar"></span> 11 | 12 | <div #navbar .collapse.navbar-collapse> 13 | <ul .nav.navbar-nav> 14 | $forall MenuItem label route _ <- navbarLeftFilteredMenuItems 15 | <li :Just route == mcurrentRoute:.active> 16 | <a href="@{route}">#{label} 17 | 18 | <ul .nav.navbar-nav.navbar-right> 19 | $forall MenuItem label route _ <- navbarRightFilteredMenuItems 20 | <li :Just route == mcurrentRoute:.active> 21 | <a href="@{route}">#{label} 22 | 23 | <!-- Page Contents --> 24 | 25 | <div .container> 26 | $if not $ Just HomeR == mcurrentRoute 27 | <ul .breadcrumb> 28 | $forall bc <- parents 29 | <li> 30 | <a href="@{fst bc}">#{snd bc} 31 | 32 | <li .active>#{title} 33 | 34 | $maybe msg <- mmsg 35 | <div .alert.alert-info #message>#{msg} 36 | 37 | 38 | $if (Just HomeR == mcurrentRoute) 39 | ^{widget} 40 | $else 41 | <div .container> 42 | <div .row> 43 | <div .col-md-12> 44 | ^{widget} 45 | 46 | <!-- Footer --> 47 | <footer .footer> 48 | <div .container> 49 | <p .text-muted> 50 | #{appCopyright $ appSettings master} 51 | -------------------------------------------------------------------------------- /proj-web/templates/default-layout.lucius: -------------------------------------------------------------------------------- 1 | .masthead, 2 | .navbar { 3 | background-color: rgb(27, 28, 29); 4 | } 5 | 6 | .navbar-default .navbar-nav > .active > a { 7 | background-color: transparent; 8 | border-bottom: 2px solid white; 9 | } 10 | 11 | .navbar-nav { 12 | padding-bottom: 1em; 13 | } 14 | 15 | .masthead { 16 | margin-top: -21px; 17 | color: white; 18 | text-align: center; 19 | min-height: 500px; 20 | } 21 | 22 | .masthead .header { 23 | max-width: 700px; 24 | margin: 0 auto; 25 | font-family: Lato,'Helvetica Neue',Arial,Helvetica,sans-serif; 26 | } 27 | 28 | .masthead h1.header { 29 | margin-top: 1em; 30 | margin-bottom: 0em; 31 | font-size: 4.5em; 32 | line-height: 1.2em; 33 | font-weight: normal; 34 | } 35 | 36 | .masthead h2 { 37 | font-size: 1.7em; 38 | font-weight: normal; 39 | } 40 | 41 | .masthead .btn { 42 | margin: 1em 0; 43 | } 44 | 45 | 46 | /* Common styles for all types */ 47 | .bs-callout { 48 | padding: 20px; 49 | margin: 20px 0; 50 | border: 1px solid #eee; 51 | border-left-width: 5px; 52 | border-radius: 3px; 53 | } 54 | 55 | .bs-callout p:last-child { 56 | margin-bottom: 0; 57 | } 58 | 59 | .bs-callout-info { 60 | border-left-color: #1b809e; 61 | } 62 | 63 | /* Space things out */ 64 | .bs-docs-section { 65 | margin-bottom: 60px; 66 | } 67 | .bs-docs-section:last-child { 68 | margin-bottom: 0; 69 | } 70 | 71 | #message { 72 | margin-bottom: 40px; 73 | } 74 | -------------------------------------------------------------------------------- /proj-web/templates/homepage.hamlet: -------------------------------------------------------------------------------- 1 | <div .masthead> 2 | <div .container> 3 | <div .row> 4 | <h1 .header> 5 | Haskell Projects 6 | <h2> 7 | Connecting Mentors and Learners 8 | <a href="http://www.yesodweb.com/book/" .btn.btn-info.btn-lg> 9 | Read the Yesod Book 10 | -------------------------------------------------------------------------------- /proj-web/templates/homepage.lucius: -------------------------------------------------------------------------------- 1 | li { 2 | line-height: 2em; 3 | font-size: 16px 4 | } 5 | -------------------------------------------------------------------------------- /proj-web/templates/profile.hamlet: -------------------------------------------------------------------------------- 1 | <div .container> 2 | <div .row> 3 | <h1 .header> 4 | Your Profile 5 | 6 | <h2> 7 | Welcome, #{userName user} 8 | 9 | <ul> 10 | <li> 11 | You joined on #{tshow (userCreated user)}. 12 | <li> 13 | You last updated your profile on #{tshow (userUpdated user)} 14 | <li> 15 | <a href=@{ ProfileR EditProfileR }> 16 | Edit your profile 17 | -------------------------------------------------------------------------------- /proj-web/templates/profile/edit.hamlet: -------------------------------------------------------------------------------- 1 | <div .container> 2 | <div .row> 3 | <h1> 4 | Edit Profile 5 | 6 | <p> 7 | there's nothing here yet lol 8 | 9 | <form method=POST action=@{ProfileR EditProfileR} enctype=#{enctype} .form> 10 | ^{formWidget} 11 | <button .submit> 12 | Submit 13 | -------------------------------------------------------------------------------- /proj-web/test/Handler/CommonSpec.hs: -------------------------------------------------------------------------------- 1 | module Handler.CommonSpec (spec) where 2 | 3 | import TestImport 4 | 5 | spec :: Spec 6 | spec = withApp $ do 7 | describe "robots.txt" $ do 8 | it "gives a 200" $ do 9 | get RobotsR 10 | statusIs 200 11 | it "has correct User-agent" $ do 12 | get RobotsR 13 | bodyContains "User-agent: *" 14 | describe "favicon.ico" $ do 15 | it "gives a 200" $ do 16 | get FaviconR 17 | statusIs 200 18 | -------------------------------------------------------------------------------- /proj-web/test/Handler/HomeSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Handler.HomeSpec (spec) where 4 | 5 | import TestImport 6 | 7 | spec :: Spec 8 | spec = withApp $ do 9 | 10 | describe "Homepage" $ do 11 | it "loads the index and checks it looks right" $ do 12 | get HomeR 13 | statusIs 200 14 | htmlAnyContain "h1" "Haskell Projects" 15 | -------------------------------------------------------------------------------- /proj-web/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /proj-web/test/TestImport.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | module TestImport 5 | ( module TestImport 6 | , module X 7 | ) where 8 | 9 | import Application (makeFoundation, makeLogWare) 10 | import ClassyPrelude as X hiding (delete, deleteBy, Handler) 11 | import Database.Persist as X hiding (get) 12 | import Database.Persist.Sql (SqlPersistM, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName) 13 | import Foundation as X 14 | import Test.Hspec as X 15 | import Text.Shakespeare.Text (st) 16 | import Yesod.Default.Config2 (useEnv, loadYamlSettings) 17 | import Yesod.Auth as X 18 | import Yesod.Test as X 19 | import Yesod.Core.Unsafe (fakeHandlerGetLogger) 20 | 21 | runDB :: SqlPersistM a -> YesodExample App a 22 | runDB query = do 23 | app <- getTestYesod 24 | liftIO $ runDBWithApp app query 25 | 26 | runDBWithApp :: App -> SqlPersistM a -> IO a 27 | runDBWithApp app query = runSqlPersistMPool query (appConnPool app) 28 | 29 | runHandler :: Handler a -> YesodExample App a 30 | runHandler handler = do 31 | app <- getTestYesod 32 | fakeHandlerGetLogger appLogger app handler 33 | 34 | 35 | withApp :: SpecWith (TestApp App) -> Spec 36 | withApp = before $ do 37 | settings <- loadYamlSettings 38 | ["config/test-settings.yml", "config/settings.yml"] 39 | [] 40 | useEnv 41 | foundation <- makeFoundation settings 42 | wipeDB foundation 43 | logWare <- liftIO $ makeLogWare foundation 44 | return (foundation, logWare) 45 | 46 | -- This function will truncate all of the tables in your database. 47 | -- 'withApp' calls it before each test, creating a clean environment for each 48 | -- spec to run in. 49 | wipeDB :: App -> IO () 50 | wipeDB app = runDBWithApp app $ do 51 | tables <- getTables 52 | case tables of 53 | [] -> pure () -- only happens if no tables are defined 54 | _ -> do 55 | sqlBackend <- ask 56 | let escapedTables = map (connEscapeName sqlBackend . DBName) tables 57 | query = "TRUNCATE TABLE " ++ intercalate ", " escapedTables 58 | rawExecute query [] 59 | 60 | getTables :: DB [Text] 61 | getTables = do 62 | tables <- rawSql [st| 63 | SELECT table_name 64 | FROM information_schema.tables 65 | WHERE table_schema = 'public'; 66 | |] [] 67 | 68 | return $ map unSingle tables 69 | -------------------------------------------------------------------------------- /proj/.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | proj.cabal 3 | *~ -------------------------------------------------------------------------------- /proj/ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Changelog for proj 2 | 3 | ## Unreleased changes 4 | -------------------------------------------------------------------------------- /proj/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Matt Parsons (c) 2018 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /proj/README.md: -------------------------------------------------------------------------------- 1 | # proj 2 | 3 | This package defines the core datatypes and business logic for the `haskell-projects` project. 4 | -------------------------------------------------------------------------------- /proj/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /proj/package.yaml: -------------------------------------------------------------------------------- 1 | name: proj 2 | version: 0.1.0.0 3 | github: parsonsmatt/haskell-projects 4 | license: BSD3 5 | author: Matthew Parsons 6 | maintainer: parsonsmatt@gmail.com 7 | copyright: 2018 Matthew Parsons 8 | 9 | extra-source-files: 10 | - README.md 11 | - ChangeLog.md 12 | 13 | # Metadata used when publishing your package 14 | # synopsis: Short description of your package 15 | # category: Web 16 | 17 | # To avoid duplicated efforts in documentation and dealing with the 18 | # complications of embedding Haddock markup inside cabal files, it is 19 | # common to point users to the README.md file. 20 | description: Please see the README on Github at <https://github.com/githubuser/proj#readme> 21 | 22 | dependencies: 23 | - base >= 4.7 && < 5 24 | - persistent 25 | - persistent-template 26 | - esqueleto 27 | - text 28 | - time 29 | 30 | library: 31 | source-dirs: src 32 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints -Werror 33 | default-extensions: 34 | - FlexibleContexts 35 | - FlexibleInstances 36 | - GADTs 37 | - GeneralizedNewtypeDeriving 38 | - MultiParamTypeClasses 39 | - ScopedTypeVariables 40 | - TypeApplications 41 | 42 | tests: 43 | proj-test: 44 | main: Spec.hs 45 | source-dirs: test 46 | ghc-options: 47 | - -threaded 48 | - -rtsopts 49 | - -with-rtsopts=-N 50 | dependencies: 51 | - proj 52 | - hspec 53 | -------------------------------------------------------------------------------- /proj/src/Proj.hs: -------------------------------------------------------------------------------- 1 | module Proj where 2 | -------------------------------------------------------------------------------- /proj/src/Proj/Models.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Proj.Models where 6 | 7 | import Data.Text (Text) 8 | import Data.Time (UTCTime) 9 | import Database.Persist (Entity) 10 | import Database.Persist.TH (mkMigrate, mkPersist, persistLowerCase, 11 | share, sqlSettings) 12 | 13 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| 14 | 15 | -- user and user management models 16 | User 17 | name Text 18 | created UTCTime 19 | updated UTCTime 20 | 21 | deriving Eq Show 22 | 23 | OauthLogin 24 | provider Text 25 | user UserId 26 | 27 | deriving Eq Show 28 | 29 | Admin 30 | user UserId 31 | created UTCTime 32 | 33 | UniqueAdmin user 34 | 35 | deriving Eq Show 36 | 37 | Learner 38 | user UserId 39 | 40 | UniqueLearner user 41 | 42 | deriving Eq Show 43 | 44 | Mentor 45 | user UserId 46 | 47 | UniqueMentor user 48 | 49 | deriving Eq Show 50 | 51 | -- projects 52 | 53 | Project 54 | name Text 55 | created UTCTime 56 | description Text 57 | creator UserId 58 | 59 | deriving Eq Show 60 | 61 | -- a join table for projects and mentors 62 | Mentorship 63 | project ProjectId 64 | mentor MentorId 65 | 66 | deriving Eq Show 67 | 68 | -- a join table for projects and learners 69 | Apprenticeship 70 | learner LearnerId 71 | project ProjectId 72 | 73 | deriving Eq Show 74 | |] 75 | 76 | -- | A 'Profile' is not something that exists in the database. It is the 77 | -- result of collecting all of a relevant user's information. 78 | data Profile 79 | = Profile 80 | { profileUser :: Entity User 81 | , profileLearner :: Maybe (Entity Learner) 82 | , profileMentor :: Maybe (Entity Mentor) 83 | , profileAdmin :: Maybe (Entity Admin) 84 | } deriving (Eq, Show) 85 | -------------------------------------------------------------------------------- /proj/src/Proj/Models/Profile.hs: -------------------------------------------------------------------------------- 1 | module Proj.Models.Profile where 2 | 3 | import Control.Monad.IO.Class 4 | import Data.Maybe 5 | import Database.Esqueleto 6 | 7 | import Proj.Models 8 | 9 | selectProfile :: MonadIO m => UserId -> SqlPersistT m (Maybe Profile) 10 | selectProfile userId = 11 | fmap (fmap conv . listToMaybe) $ 12 | select $ 13 | from $ \(user `LeftOuterJoin` mentor `LeftOuterJoin` learner `LeftOuterJoin` admin) -> do 14 | on (just (user ^. UserId) ==. admin ?. AdminUser) 15 | on (just (user ^. UserId) ==. learner ?. LearnerUser) 16 | on (just (user ^. UserId) ==. mentor ?. MentorUser) 17 | where_ (user ^. UserId ==. val userId) 18 | limit 1 19 | return (user, learner, mentor, admin) 20 | where 21 | conv (euser, elearner, ementor, eadmin) = 22 | Profile euser elearner ementor eadmin 23 | -------------------------------------------------------------------------------- /proj/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | 3 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.10 2 | 3 | packages: 4 | - proj 5 | - proj-web 6 | 7 | extra-deps: 8 | - yesod-auth-oauth2-0.4.0.1 9 | --------------------------------------------------------------------------------