feat: Scaffold an Yesod application

Right now I have no idea how it works, but it builds with "stack
build" and serves something on localhost:3000. I am not exactly happy
that building and interactive development depends on "stack(1)"
instead of more familiar "cabal repl", but I can live with it.

It requires Postgres database running on the localhost, which is
configured in my NixOS configuration, and not inside of this
repository. Probably can be done better.
This commit is contained in:
Dmitry Bogatov 2024-02-11 03:23:49 -05:00
commit b074e81b2b
49 changed files with 9480 additions and 0 deletions

4
.dir-locals.el Normal file
View File

@ -0,0 +1,4 @@
((haskell-mode . ((haskell-indent-spaces . 4)
(haskell-process-use-ghci . t)))
(hamlet-mode . ((hamlet/basic-offset . 4)
(haskell-process-use-ghci . t))))

9
.envrc Normal file
View File

@ -0,0 +1,9 @@
#!/usr/bin/env bash
# the shebang is ignored, but nice for editors
if type -P lorri &>/dev/null; then
eval "$(lorri direnv)"
else
echo 'while direnv evaluated .envrc, could not find the command "lorri" [https://github.com/nix-community/lorri]'
use nix
fi

22
.gitignore vendored Normal file
View File

@ -0,0 +1,22 @@
dist*
static/tmp/
static/combined/
config/client_session_key.aes
*.hi
*.o
*.sqlite3
*.sqlite3-shm
*.sqlite3-wal
.hsenv*
cabal-dev/
.stack-work/
.stack-work-devel/
yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
*.swp
*.keter
*~
\#*
chirp.cabal

54
README.md Normal file
View File

@ -0,0 +1,54 @@
## Database Setup
After installing Postgres, run:
```
createuser chirp --pwprompt --superuser
# Enter password chirp when prompted
createdb chirp
createdb chirp_test
```
## Haskell Setup
1. If you haven't already, [install Stack](https://haskell-lang.org/get-started)
* On POSIX systems, this is usually `curl -sSL https://get.haskellstack.org/ | sh`
2. Install the `yesod` command line tool: `stack install yesod-bin --install-ghc`
3. Build libraries: `stack build`
If you have trouble, refer to the [Yesod Quickstart guide](https://www.yesodweb.com/page/quickstart) for additional detail.
## Development
Start a development server with:
```
stack exec -- yesod devel
```
As your code changes, your site will be automatically recompiled and redeployed to localhost.
## Tests
```
stack test --flag chirp:library-only --flag chirp:dev
```
(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).
## Documentation
* Read the [Yesod Book](https://www.yesodweb.com/book) online for free
* 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.
* For local documentation, use:
* `stack haddock --open` to generate Haddock documentation for your dependencies, and open that documentation in a browser
* `stack hoogle <function, module or type signature>` to generate a Hoogle database and search for your query
* The [Yesod cookbook](https://github.com/yesodweb/yesod-cookbook) has sample code for various needs
## Getting Help
* Ask questions on [Stack Overflow, using the Yesod or Haskell tags](https://stackoverflow.com/questions/tagged/yesod+haskell)
* Ask the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb)
* There are several chatrooms you can ask for help:
* For IRC, try Freenode#yesod and Freenode#haskell
* [Functional Programming Slack](https://fpchat-invite.herokuapp.com/), in the #haskell, #haskell-beginners, or #yesod channels.

105
app/DevelMain.hs Normal file
View File

@ -0,0 +1,105 @@
-- | Running your app inside GHCi.
--
-- This option provides significantly faster code reload compared to
-- @yesod devel@. However, you do not get automatic code reload
-- (which may be a benefit, depending on your perspective). To use this:
--
-- 1. Start up GHCi
--
-- $ stack ghci chirp:lib --no-load --work-dir .stack-work-devel
--
-- 2. Load this module
--
-- > :l app/DevelMain.hs
--
-- 3. Run @update@
--
-- > DevelMain.update
--
-- 4. Your app should now be running, you can connect at http://localhost:3000
--
-- 5. Make changes to your code
--
-- 6. After saving your changes, reload by running:
--
-- > :r
-- > DevelMain.update
--
-- You can also call @DevelMain.shutdown@ to stop the app
--
-- There is more information about this approach,
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
--
-- WARNING: GHCi does not notice changes made to your template files.
-- If you change a template, you'll need to either exit GHCi and reload,
-- or manually @touch@ another Haskell module.
module DevelMain where
import Prelude
import Application (getApplicationRepl, shutdownApp)
import Control.Monad ((>=>))
import Control.Concurrent
import Data.IORef
import Foreign.Store
import Network.Wai.Handler.Warp
import GHC.Word
-- | Start or restart the server.
-- newStore is from foreign-store.
-- A Store holds onto some data across ghci reloads
update :: IO ()
update = do
mtidStore <- lookupStore tidStoreNum
case mtidStore of
-- no server running
Nothing -> do
done <- storeAction doneStore newEmptyMVar
tid <- start done
_ <- storeAction (Store tidStoreNum) (newIORef tid)
return ()
-- server is already running
Just tidStore -> restartAppInNewThread tidStore
where
doneStore :: Store (MVar ())
doneStore = Store 0
-- shut the server down with killThread and wait for the done signal
restartAppInNewThread :: Store (IORef ThreadId) -> IO ()
restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do
killThread tid
withStore doneStore takeMVar
readStore doneStore >>= start
-- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId
start done = do
(port, site, app) <- getApplicationRepl
forkFinally
(runSettings (setPort port defaultSettings) app)
-- Note that this implies concurrency
-- between shutdownApp and the next app that is starting.
-- Normally this should be fine
(\_ -> putMVar done () >> shutdownApp site)
-- | kill the server
shutdown :: IO ()
shutdown = do
mtidStore <- lookupStore tidStoreNum
case mtidStore of
-- no server running
Nothing -> putStrLn "no Yesod app running"
Just tidStore -> do
withStore tidStore $ readIORef >=> killThread
putStrLn "Yesod app is shutdown"
tidStoreNum :: Word32
tidStoreNum = 1
modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
modifyStoredIORef store f = withStore store $ \ref -> do
v <- readIORef ref
f v >>= writeIORef ref

6
app/devel.hs Normal file
View File

@ -0,0 +1,6 @@
{-# LANGUAGE PackageImports #-}
import "chirp" Application (develMain)
import Prelude (IO)
main :: IO ()
main = develMain

5
app/main.hs Normal file
View File

@ -0,0 +1,5 @@
import Prelude (IO)
import Application (appMain)
main :: IO ()
main = appMain

BIN
config/favicon.ico Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 1.3 KiB

73
config/keter.yml Normal file
View File

@ -0,0 +1,73 @@
# After you've edited this file, remove the following line to allow
# `yesod keter` to build your bundle.
#
# Also, please make sure that `port` value on `config/settings.yaml` is set to
# use `PORT` env variable.
user-edited: false
# A Keter app is composed of 1 or more stanzas. The main stanza will define our
# web application. See the Keter documentation for more information on
# available stanzas.
stanzas:
# Your Yesod application.
- type: webapp
# Name of your executable. You are unlikely to need to change this.
# Note that all file paths are relative to the keter.yml file.
#
# The path given is for Stack projects. If you're still using cabal, change
# to
# exec: ../dist/build/chirp/chirp
exec: ../dist/bin/chirp
# Command line options passed to your application.
args: []
hosts:
# You can specify one or more hostnames for your application to respond
# to. The primary hostname will be used for generating your application
# root.
- www.chirp.com
# Enable to force Keter to redirect to https
# Can be added to any stanza
requires-secure: false
# Static files.
- type: static-files
hosts:
- static.chirp.com
root: ../static
# Uncomment to turn on directory listings.
# directory-listing: true
# Redirect plain domain name to www.
- type: redirect
hosts:
- chirp.com
actions:
- host: www.chirp.com
# secure: false
# port: 80
# Uncomment to switch to a non-permanent redirect.
# status: 303
# Use the following to automatically copy your bundle upon creation via `yesod
# keter`. Uses `scp` internally, so you can set it to a remote destination
# copy-to: user@host:/opt/keter/incoming/
# You can pass arguments to `scp` used above. This example limits bandwidth to
# 1024 Kbit/s and uses port 2222 instead of the default 22
# copy-to-args:
# - "-l 1024"
# - "-P 2222"
# If you would like to have Keter automatically create a PostgreSQL database
# and set appropriate environment variables for it to be discovered, uncomment
# the following line.
# plugins:
# postgres: true

View File

@ -0,0 +1,18 @@
-- By default this file is used by `persistFileWith` in Model.hs (which is imported by Foundation.hs)
-- Syntax for this file here: https://github.com/yesodweb/persistent/blob/master/docs/Persistent-entity-syntax.md
User
ident Text
password Text Maybe
UniqueUser ident
deriving Typeable
Email
email Text
userId UserId Maybe
verkey Text Maybe
UniqueEmail email
Comment json -- Adding "json" causes ToJSON and FromJSON instances to be derived.
message Text
userId UserId Maybe
deriving Eq
deriving Show

1
config/robots.txt Normal file
View File

@ -0,0 +1 @@
User-agent: *

14
config/routes.yesodroutes Normal file
View File

@ -0,0 +1,14 @@
-- By default this file is used by `parseRoutesFile` in Foundation.hs
-- Syntax for this file here: https://www.yesodweb.com/book/routing-and-handlers
/static StaticR Static appStatic
/auth AuthR Auth getAuth
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/ HomeR GET POST
/comments CommentR POST
/profile ProfileR GET

44
config/settings.yml Normal file
View File

@ -0,0 +1,44 @@
# Values formatted like "_env:YESOD_ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
# See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables
static-dir: "_env:YESOD_STATIC_DIR:static"
host: "_env:YESOD_HOST:*4" # any IPv4 host
port: "_env:YESOD_PORT:3000" # NB: The port `yesod devel` uses is distinct from this value. Set the `yesod devel` port from the command line.
# For `keter` user, enable the follwing line, and comment out previous one.
#port: "_env:PORT:3000" # `keter` uses `PORT` env var name
ip-from-header: "_env:YESOD_IP_FROM_HEADER:false"
# Default behavior: determine the application root from the request headers.
# Uncomment to set an explicit approot
#approot: "_env:YESOD_APPROOT:http://localhost:3000"
# By default, `yesod devel` runs in development, and built executables use
# production settings (see below). To override this, use the following:
#
# development: false
# Optional values with the following production defaults.
# In development, they default to the inverse.
#
# detailed-logging: false
# should-log-all: false
# reload-templates: false
# mutable-static: false
# skip-combining: false
# auth-dummy-login : false
# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:YESOD_PGPASS:'123'")
# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings
database:
user: "_env:YESOD_PGUSER:chirp"
password: "_env:YESOD_PGPASS:chirp"
host: "_env:YESOD_PGHOST:/run/postgresql"
port: "_env:YESOD_PGPORT:5432"
# See config/test-settings.yml for an override during tests
database: "_env:YESOD_PGDATABASE:chirp"
poolsize: "_env:YESOD_PGPOOLSIZE:10"
copyright: Insert copyright statement here
#analytics: UA-YOURCODE

11
config/test-settings.yml Normal file
View File

@ -0,0 +1,11 @@
database:
# NOTE: By design, this setting prevents the PGDATABASE environment variable
# from affecting test runs, so that we don't accidentally affect the
# production database during testing. If you're not concerned about that and
# would like to have environment variable overrides, you could instead use
# something like:
#
# database: "_env:PGDATABASE:chirp_test"
database: chirp_test
auth-dummy-login: true

14
nix/sources.json Normal file
View File

@ -0,0 +1,14 @@
{
"nixpkgs": {
"branch": "master",
"description": "Nix Packages collection",
"homepage": null,
"owner": "nixos",
"repo": "nixpkgs",
"rev": "7ff7d29867a760ebba1ed724f06e2543d41ab0fd",
"sha256": "1krr9fwizmbgnfivzqw7d7lfzqprkg0vdzaa3d607ls7narqblrv",
"type": "tarball",
"url": "https://github.com/nixos/nixpkgs/archive/7ff7d29867a760ebba1ed724f06e2543d41ab0fd.tar.gz",
"url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz"
}
}

198
nix/sources.nix Normal file
View File

@ -0,0 +1,198 @@
# This file has been generated by Niv.
let
#
# The fetchers. fetch_<type> fetches specs of type <type>.
#
fetch_file = pkgs: name: spec:
let
name' = sanitizeName name + "-src";
in
if spec.builtin or true then
builtins_fetchurl { inherit (spec) url sha256; name = name'; }
else
pkgs.fetchurl { inherit (spec) url sha256; name = name'; };
fetch_tarball = pkgs: name: spec:
let
name' = sanitizeName name + "-src";
in
if spec.builtin or true then
builtins_fetchTarball { name = name'; inherit (spec) url sha256; }
else
pkgs.fetchzip { name = name'; inherit (spec) url sha256; };
fetch_git = name: spec:
let
ref =
spec.ref or (
if spec ? branch then "refs/heads/${spec.branch}" else
if spec ? tag then "refs/tags/${spec.tag}" else
abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"
);
submodules = spec.submodules or false;
submoduleArg =
let
nixSupportsSubmodules = builtins.compareVersions builtins.nixVersion "2.4" >= 0;
emptyArgWithWarning =
if submodules
then
builtins.trace
(
"The niv input \"${name}\" uses submodules "
+ "but your nix's (${builtins.nixVersion}) builtins.fetchGit "
+ "does not support them"
)
{ }
else { };
in
if nixSupportsSubmodules
then { inherit submodules; }
else emptyArgWithWarning;
in
builtins.fetchGit
({ url = spec.repo; inherit (spec) rev; inherit ref; } // submoduleArg);
fetch_local = spec: spec.path;
fetch_builtin-tarball = name: throw
''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`.
$ niv modify ${name} -a type=tarball -a builtin=true'';
fetch_builtin-url = name: throw
''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`.
$ niv modify ${name} -a type=file -a builtin=true'';
#
# Various helpers
#
# https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695
sanitizeName = name:
(
concatMapStrings (s: if builtins.isList s then "-" else s)
(
builtins.split "[^[:alnum:]+._?=-]+"
((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name)
)
);
# The set of packages used when specs are fetched using non-builtins.
mkPkgs = sources: system:
let
sourcesNixpkgs =
import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; };
hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath;
hasThisAsNixpkgsPath = <nixpkgs> == ./.;
in
if builtins.hasAttr "nixpkgs" sources
then sourcesNixpkgs
else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then
import <nixpkgs> { }
else
abort
''
Please specify either <nixpkgs> (through -I or NIX_PATH=nixpkgs=...) or
add a package called "nixpkgs" to your sources.json.
'';
# The actual fetching function.
fetch = pkgs: name: spec:
if ! builtins.hasAttr "type" spec then
abort "ERROR: niv spec ${name} does not have a 'type' attribute"
else if spec.type == "file" then fetch_file pkgs name spec
else if spec.type == "tarball" then fetch_tarball pkgs name spec
else if spec.type == "git" then fetch_git name spec
else if spec.type == "local" then fetch_local spec
else if spec.type == "builtin-tarball" then fetch_builtin-tarball name
else if spec.type == "builtin-url" then fetch_builtin-url name
else
abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}";
# If the environment variable NIV_OVERRIDE_${name} is set, then use
# the path directly as opposed to the fetched source.
replace = name: drv:
let
saneName = stringAsChars (c: if (builtins.match "[a-zA-Z0-9]" c) == null then "_" else c) name;
ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}";
in
if ersatz == "" then drv else
# this turns the string into an actual Nix path (for both absolute and
# relative paths)
if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}";
# Ports of functions for older nix versions
# a Nix version of mapAttrs if the built-in doesn't exist
mapAttrs = builtins.mapAttrs or (
f: set: with builtins;
listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set))
);
# https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295
range = first: last: if first > last then [ ] else builtins.genList (n: first + n) (last - first + 1);
# https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257
stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1));
# https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269
stringAsChars = f: s: concatStrings (map f (stringToCharacters s));
concatMapStrings = f: list: concatStrings (map f list);
concatStrings = builtins.concatStringsSep "";
# https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331
optionalAttrs = cond: as: if cond then as else { };
# fetchTarball version that is compatible between all the versions of Nix
builtins_fetchTarball = { url, name ? null, sha256 }@attrs:
let
inherit (builtins) lessThan nixVersion fetchTarball;
in
if lessThan nixVersion "1.12" then
fetchTarball ({ inherit url; } // (optionalAttrs (name != null) { inherit name; }))
else
fetchTarball attrs;
# fetchurl version that is compatible between all the versions of Nix
builtins_fetchurl = { url, name ? null, sha256 }@attrs:
let
inherit (builtins) lessThan nixVersion fetchurl;
in
if lessThan nixVersion "1.12" then
fetchurl ({ inherit url; } // (optionalAttrs (name != null) { inherit name; }))
else
fetchurl attrs;
# Create the final "sources" from the config
mkSources = config:
mapAttrs
(
name: spec:
if builtins.hasAttr "outPath" spec
then
abort
"The values in sources.json should not have an 'outPath' attribute"
else
spec // { outPath = replace name (fetch config.pkgs name spec); }
)
config.sources;
# The "config" used by the fetchers
mkConfig =
{ sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null
, sources ? if sourcesFile == null then { } else builtins.fromJSON (builtins.readFile sourcesFile)
, system ? builtins.currentSystem
, pkgs ? mkPkgs sources system
}: rec {
# The sources, i.e. the attribute set of spec name to spec
inherit sources;
# The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers
inherit pkgs;
};
in
mkSources (mkConfig { }) // { __functor = _: settings: mkSources (mkConfig settings); }

99
package.yaml Normal file
View File

@ -0,0 +1,99 @@
name: chirp
version: "0.0.0"
dependencies:
- base >=4.9.1.0 && <5
- yesod >=1.6 && <1.7
- yesod-core >=1.6 && <1.7
- yesod-auth >=1.6 && <1.7
- yesod-static >=1.6 && <1.7
- yesod-form >=1.6 && <1.8
- classy-prelude >=1.5 && <1.6
- classy-prelude-conduit >=1.5 && <1.6
- classy-prelude-yesod >=1.5 && <1.6
- bytestring >=0.10 && <0.12
- text >=0.11 && <2.0
- persistent >=2.9 && <2.14
- persistent-postgresql >=2.13 && <2.14
- persistent-template >=2.5 && <2.14
- template-haskell
- shakespeare >=2.0 && <2.1
- hjsmin >=0.1 && <0.3
- monad-control >=0.3 && <1.1
- wai-extra >=3.0 && <3.2
- yaml >=0.11 && <0.12
- http-client-tls >=0.3 && <0.4
- http-conduit >=2.3 && <2.4
- directory >=1.1 && <1.4
- warp >=3.0 && <3.4
- data-default
- aeson >=1.4 && <2.1
- conduit >=1.0 && <2.0
- monad-logger >=0.3 && <0.4
- fast-logger >=2.2 && <3.2
- wai-logger >=2.2 && <2.5
- file-embed
- safe
- unordered-containers
- containers
- vector
- time
- case-insensitive
- wai
- foreign-store
# The library contains all of our application code. The executable
# defined below is just a thin wrapper.
library:
source-dirs: src
when:
- condition: (flag(dev)) || (flag(library-only))
then:
ghc-options:
- -Wall
- -fwarn-tabs
- -O0
cpp-options: -DDEVELOPMENT
else:
ghc-options:
- -Wall
- -fwarn-tabs
- -O2
# Runnable executable for our application
executables:
chirp:
main: main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- chirp
when:
- condition: flag(library-only)
buildable: false
# Test suite
tests:
chirp-test:
main: Spec.hs
source-dirs: test
ghc-options: -Wall
dependencies:
- chirp
- hspec >=2.0.0
- yesod-test
# Define flags used by "yesod devel" to make compilation faster
flags:
library-only:
description: Build for use with "yesod devel"
manual: false
default: false
dev:
description: Turn on development settings, like auto-reload templates.
manual: false
default: false

14
shell.nix Normal file
View File

@ -0,0 +1,14 @@
{
sources ? import ./nix/sources.nix,
nixpkgs ? sources.nixpkgs,
pkgs ? import nixpkgs {},
}:
pkgs.mkShell {
buildInputs = [
pkgs.haskellPackages.yesod-bin
pkgs.stack
pkgs.postgresql.lib
pkgs.libz
];
}

190
src/Application.hs Normal file
View File

@ -0,0 +1,190 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( getApplicationDev
, appMain
, develMain
, makeFoundation
, makeLogWare
-- * for DevelMain
, getApplicationRepl
, shutdownApp
-- * for GHCI
, handler
, db
) where
import Control.Monad.Logger (liftLoc, runLoggingT)
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr,
pgPoolSize, runSqlPool)
import Import
import Language.Haskell.TH.Syntax (qLocation)
import Network.HTTP.Client.TLS (getGlobalManager)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Settings, defaultSettings,
defaultShouldDisplayException,
runSettings, setHost,
setOnException, setPort, getPort)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..),
OutputFormat (..), destination,
mkRequestLogger, outputFormat)
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
toLogStr)
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Common
import Handler.Home
import Handler.Comment
import Handler.Profile
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
-- comments there for more details.
mkYesodDispatch "App" resourcesApp
-- | This function allocates resources (such as a database connection pool),
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO App
makeFoundation appSettings = do
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
appHttpManager <- getGlobalManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <-
(if appMutableStatic appSettings then staticDevel else static)
(appStaticDir appSettings)
-- We need a log function to create a connection pool. We need a connection
-- pool to create our foundation. And we need our foundation to get a
-- logging function. To get out of this loop, we initially create a
-- temporary foundation without a real connection pool, get a log function
-- from there, and then create the real foundation.
let mkFoundation appConnPool = App {..}
-- The App {..} syntax is an example of record wild cards. For more
-- information, see:
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
logFunc = messageLoggerSource tempFoundation appLogger
-- Create the database connection pool
pool <- flip runLoggingT logFunc $ createPostgresqlPool
(pgConnStr $ appDatabaseConf appSettings)
(pgPoolSize $ appDatabaseConf appSettings)
-- Perform database migration using our application's logging settings.
runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
-- Return the foundation
return $ mkFoundation pool
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: App -> IO Application
makeApplication foundation = do
logWare <- makeLogWare foundation
-- Create the WAI application and apply middlewares
appPlain <- toWaiAppPlain foundation
return $ logWare $ defaultMiddlewaresNoLogging appPlain
makeLogWare :: App -> IO Middleware
makeLogWare foundation =
mkRequestLogger def
{ outputFormat =
if appDetailedRequestLogging $ appSettings foundation
then Detailed True
else Apache
(if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket)
, destination = Logger $ loggerSet $ appLogger foundation
}
-- | Warp settings for the given foundation value.
warpSettings :: App -> Settings
warpSettings foundation =
setPort (appPort $ appSettings foundation)
$ setHost (appHost $ appSettings foundation)
$ setOnException (\_req e ->
when (defaultShouldDisplayException e) $ messageLoggerSource
foundation
(appLogger foundation)
$(qLocation >>= liftLoc)
"yesod"
LevelError
(toLogStr $ "Exception from Warp: " ++ show e))
defaultSettings
-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: IO (Settings, Application)
getApplicationDev = do
settings <- getAppSettings
foundation <- makeFoundation settings
wsettings <- getDevSettings $ warpSettings foundation
app <- makeApplication foundation
return (wsettings, app)
getAppSettings :: IO AppSettings
getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
-- | main function for use by yesod devel
develMain :: IO ()
develMain = develMainHelper getApplicationDev
-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain = do
-- Get the settings from all relevant sources
settings <- loadYamlSettingsArgs
-- fall back to compile-time values, set to [] to require values at runtime
[configSettingsYmlValue]
-- allow environment variables to override
useEnv
-- Generate the foundation from the settings
foundation <- makeFoundation settings
-- Generate a WAI Application from the foundation
app <- makeApplication foundation
-- Run the application with Warp
runSettings (warpSettings foundation) app
--------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the app from GHCi)
--------------------------------------------------------------
getApplicationRepl :: IO (Int, App, Application)
getApplicationRepl = do
settings <- getAppSettings
foundation <- makeFoundation settings
wsettings <- getDevSettings $ warpSettings foundation
app1 <- makeApplication foundation
return (getPort wsettings, foundation, app1)
shutdownApp :: App -> IO ()
shutdownApp _ = return ()
---------------------------------------------
-- Functions for use in development with GHCi
---------------------------------------------
-- | Run a handler
handler :: Handler a -> IO a
handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
-- | Run DB queries
db :: ReaderT SqlBackend Handler a -> IO a
db = handler . runDB

299
src/Foundation.hs Normal file
View File

@ -0,0 +1,299 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE InstanceSigs #-}
module Foundation where
import Import.NoFoundation
import Data.Kind (Type)
import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym)
import Control.Monad.Logger (LogSource)
-- Used only when in "auth-dummy-login" setting is enabled.
import Yesod.Auth.Dummy
import Yesod.Auth.OpenId (authOpenId, IdentifierType (Claimed))
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Core.Types (Logger)
import qualified Yesod.Core.Unsafe as Unsafe
import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding as TE
-- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data App = App
{ appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving.
, appConnPool :: ConnectionPool -- ^ Database connection pool.
, appHttpManager :: Manager
, appLogger :: Logger
}
data MenuItem = MenuItem
{ menuItemLabel :: Text
, menuItemRoute :: Route App
, menuItemAccessCallback :: Bool
}
data MenuTypes
= NavbarLeft MenuItem
| NavbarRight MenuItem
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers
--
-- Note that this is really half the story; in Application.hs, mkYesodDispatch
-- generates the rest of the code. Please see the following documentation
-- for an explanation for this split:
-- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
--
-- This function also generates the following type synonyms:
-- type Handler = HandlerFor App
-- type Widget = WidgetFor App ()
mkYesodData "App" $(parseRoutesFile "config/routes.yesodroutes")
-- | A convenient synonym for creating forms.
type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)
-- | A convenient synonym for database access functions.
type DB a = forall (m :: Type -> Type).
(MonadUnliftIO m) => ReaderT SqlBackend m a
-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance Yesod App where
-- Controls the base of generated URLs. For more information on modifying,
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
approot :: Approot App
approot = ApprootRequest $ \app req ->
case appRoot $ appSettings app of
Nothing -> getApprootText guessApproot app req
Just root -> root
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
makeSessionBackend :: App -> IO (Maybe SessionBackend)
makeSessionBackend _ = Just <$> defaultClientSessionBackend
120 -- timeout in minutes
"config/client_session_key.aes"
-- Yesod Middleware allows you to run code before and after each handler function.
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
-- Some users may also want to add the defaultCsrfMiddleware, which:
-- a) Sets a cookie with a CSRF token in it.
-- b) Validates that incoming write requests include that token in either a header or POST parameter.
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
yesodMiddleware = defaultYesodMiddleware
defaultLayout :: Widget -> Handler Html
defaultLayout widget = do
master <- getYesod
mmsg <- getMessage
muser <- maybeAuthPair
mcurrentRoute <- getCurrentRoute
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
(title, parents) <- breadcrumbs
-- Define the menu items of the header.
let menuItems =
[ NavbarLeft $ MenuItem
{ menuItemLabel = "Home"
, menuItemRoute = HomeR
, menuItemAccessCallback = True
}
, NavbarLeft $ MenuItem
{ menuItemLabel = "Profile"
, menuItemRoute = ProfileR
, menuItemAccessCallback = isJust muser
}
, NavbarRight $ MenuItem
{ menuItemLabel = "Login"
, menuItemRoute = AuthR LoginR
, menuItemAccessCallback = isNothing muser
}
, NavbarRight $ MenuItem
{ menuItemLabel = "Logout"
, menuItemRoute = AuthR LogoutR
, menuItemAccessCallback = isJust muser
}
]
let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems]
let navbarRightMenuItems = [x | NavbarRight x <- menuItems]
let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x]
let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x]
-- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and
-- default-layout-wrapper is the entire page. Since the final
-- value passed to hamletToRepHtml cannot be a widget, this allows
-- you to use normal widget features in default-layout.
pc <- widgetToPageContent $ do
addStylesheet $ StaticR css_bootstrap_css
-- ^ generated from @Settings/StaticFiles.hs@
$(widgetFile "default-layout")
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-- The page to be redirected to when authentication is required.
authRoute
:: App
-> Maybe (Route App)
authRoute _ = Just $ AuthR LoginR
isAuthorized
:: Route App -- ^ The route the user is visiting.
-> Bool -- ^ Whether or not this is a "write" request.
-> Handler AuthResult
-- Routes not requiring authentication.
isAuthorized (AuthR _) _ = return Authorized
isAuthorized CommentR _ = return Authorized
isAuthorized HomeR _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
isAuthorized (StaticR _) _ = return Authorized
-- the profile route requires that the user is authenticated, so we
-- delegate to that function
isAuthorized ProfileR _ = isAuthenticated
-- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows
-- expiration dates to be set far in the future without worry of
-- users receiving stale content.
addStaticContent
:: Text -- ^ The file extension
-> Text -- ^ The MIME content type
-> LByteString -- ^ The contents of the file
-> Handler (Maybe (Either Text (Route App, [(Text, Text)])))
addStaticContent ext mime content = do
master <- getYesod
let staticDir = appStaticDir $ appSettings master
addStaticContentExternal
minifym
genFileName
staticDir
(StaticR . flip StaticRoute [])
ext
mime
content
where
-- Generate a unique filename based on the content itself
genFileName lbs = "autogen-" ++ base64md5 lbs
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level =
return $
appShouldLogAll (appSettings app)
|| level == LevelWarn
|| level == LevelError
makeLogger :: App -> IO Logger
makeLogger = return . appLogger
-- Define breadcrumbs.
instance YesodBreadcrumbs App where
-- Takes the route that the user is currently on, and returns a tuple
-- of the 'Text' that you want the label to display, and a previous
-- breadcrumb route.
breadcrumb
:: Route App -- ^ The route the user is visiting currently.
-> Handler (Text, Maybe (Route App))
breadcrumb HomeR = return ("Home", Nothing)
breadcrumb (AuthR _) = return ("Login", Just HomeR)
breadcrumb ProfileR = return ("Profile", Just HomeR)
breadcrumb _ = return ("home", Nothing)
-- How to run database actions.
instance YesodPersist App where
type YesodPersistBackend App = SqlBackend
runDB :: SqlPersistT Handler a -> Handler a
runDB action = do
master <- getYesod
runSqlPool action $ appConnPool master
instance YesodPersistRunner App where
getDBRunner :: Handler (DBRunner App, Handler ())
getDBRunner = defaultGetDBRunner appConnPool
instance YesodAuth App where
type AuthId App = UserId
-- Where to send a user after successful login
loginDest :: App -> Route App
loginDest _ = HomeR
-- Where to send a user after logout
logoutDest :: App -> Route App
logoutDest _ = HomeR
-- Override the above two destinations when a Referer: header is present
redirectToReferer :: App -> Bool
redirectToReferer _ = True
authenticate :: (MonadHandler m, HandlerSite m ~ App)
=> Creds App -> m (AuthenticationResult App)
authenticate creds = liftHandler $ runDB $ do
x <- getBy $ UniqueUser $ credsIdent creds
case x of
Just (Entity uid _) -> return $ Authenticated uid
Nothing -> Authenticated <$> insert User
{ userIdent = credsIdent creds
, userPassword = Nothing
}
-- You can add other plugins like Google Email, email or OAuth here
authPlugins :: App -> [AuthPlugin App]
authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins
-- Enable authDummy login if enabled.
where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app]
-- | Access function to determine if a user is logged in.
isAuthenticated :: Handler AuthResult
isAuthenticated = do
muid <- maybeAuthId
return $ case muid of
Nothing -> Unauthorized "You must login to access this page"
Just _ -> Authorized
instance YesodAuthPersist App
-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage App FormMessage where
renderMessage :: App -> [Lang] -> FormMessage -> Text
renderMessage _ _ = defaultFormMessage
-- Useful when writing code that is re-usable outside of the Handler context.
-- An example is background jobs that send email.
-- This can also be useful for writing code that works across multiple Yesod applications.
instance HasHttpManager App where
getHttpManager :: App -> Manager
getHttpManager = appHttpManager
unsafeHandler :: App -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- Note: Some functionality previously present in the scaffolding has been
-- moved to documentation in the Wiki. Following are some hopefully helpful
-- links:
--
-- https://github.com/yesodweb/yesod/wiki/Sending-email
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding

16
src/Handler/Comment.hs Normal file
View File

@ -0,0 +1,16 @@
module Handler.Comment where
import Import
postCommentR :: Handler Value
postCommentR = do
-- requireCheckJsonBody will parse the request body into the appropriate type, or return a 400 status code if the request JSON is invalid.
-- (The ToJSON and FromJSON instances are derived in the config/models file).
comment <- (requireCheckJsonBody :: Handler Comment)
-- The YesodAuth instance in Foundation.hs defines the UserId to be the type used for authentication.
maybeCurrentUserId <- maybeAuthId
let comment' = comment { commentUserId = maybeCurrentUserId }
insertedComment <- runDB $ insertEntity comment'
returnJson insertedComment

22
src/Handler/Common.hs Normal file
View File

@ -0,0 +1,22 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
-- | Common handler functions.
module Handler.Common where
import Data.FileEmbed (embedFile)
import Import
-- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency.
getFaviconR :: Handler TypedContent
getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
return $ TypedContent "image/x-icon"
$ toContent $(embedFile "config/favicon.ico")
getRobotsR :: Handler TypedContent
getRobotsR = return $ TypedContent typePlain
$ toContent $(embedFile "config/robots.txt")

73
src/Handler/Home.hs Normal file
View File

@ -0,0 +1,73 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.Home where
import Import
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Text.Julius (RawJS (..))
-- Define our data that will be used for creating the form.
data FileForm = FileForm
{ fileInfo :: FileInfo
, fileDescription :: Text
}
-- This is a handler function for the GET request method on the HomeR
-- resource pattern. All of your resource patterns are defined in
-- config/routes.yesodroutes
--
-- The majority of the code you will write in Yesod lives in these handler
-- functions. You can spread them across multiple files if you are so
-- inclined, or create a single monolithic file.
getHomeR :: Handler Html
getHomeR = do
(formWidget, formEnctype) <- generateFormPost sampleForm
let submission = Nothing :: Maybe FileForm
handlerName = "getHomeR" :: Text
allComments <- runDB $ getAllComments
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
postHomeR :: Handler Html
postHomeR = do
((result, formWidget), formEnctype) <- runFormPost sampleForm
let handlerName = "postHomeR" :: Text
submission = case result of
FormSuccess res -> Just res
_ -> Nothing
allComments <- runDB $ getAllComments
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
sampleForm :: Form FileForm
sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
<$> fileAFormReq "Choose a file"
<*> areq textField textSettings Nothing
-- Add attributes like the placeholder and CSS classes.
where textSettings = FieldSettings
{ fsLabel = "What's on the file?"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs =
[ ("class", "form-control")
, ("placeholder", "File description")
]
}
commentIds :: (Text, Text, Text)
commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")
getAllComments :: DB [Entity Comment]
getAllComments = selectList [] [Asc CommentId]

15
src/Handler/Profile.hs Normal file
View File

@ -0,0 +1,15 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.Profile where
import Import
getProfileR :: Handler Html
getProfileR = do
(_, user) <- requireAuthPair
defaultLayout $ do
setTitle . toHtml $ userIdent user <> "'s User page"
$(widgetFile "profile")

6
src/Import.hs Normal file
View File

@ -0,0 +1,6 @@
module Import
( module Import
) where
import Foundation as Import
import Import.NoFoundation as Import

View File

@ -0,0 +1,12 @@
{-# LANGUAGE CPP #-}
module Import.NoFoundation
( module Import
) where
import ClassyPrelude.Yesod as Import
import Model as Import
import Settings as Import
import Settings.StaticFiles as Import
import Yesod.Auth as Import
import Yesod.Core.Types as Import (loggerSet)
import Yesod.Default.Config2 as Import

24
src/Model.hs Normal file
View File

@ -0,0 +1,24 @@
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE DataKinds #-}
module Model where
import ClassyPrelude.Yesod
import Database.Persist.Quasi
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
-- at:
-- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlSettings, mkMigrate "migrateAll"]
$(persistFileWith lowerCaseSettings "config/models.persistentmodels")

149
src/Settings.hs Normal file
View File

@ -0,0 +1,149 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
-- | Settings are centralized, as much as possible, into this file. This
-- includes database connection settings, static file locations, etc.
-- In addition, you can configure a number of different aspects of Yesod
-- by overriding methods in the Yesod typeclass. That instance is
-- declared in the Foundation.hs file.
module Settings where
import ClassyPrelude.Yesod
import qualified Control.Exception as Exception
import Data.Aeson (Result (..), fromJSON, withObject,
(.!=), (.:?))
import Data.FileEmbed (embedFile)
import Data.Yaml (decodeEither')
import Database.Persist.Postgresql (PostgresConf)
import Language.Haskell.TH.Syntax (Exp, Name, Q)
import Network.Wai.Handler.Warp (HostPreference)
import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
import Yesod.Default.Util (WidgetFileSettings,
widgetFileNoReload,
widgetFileReload)
-- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files,
-- theoretically even a database.
data AppSettings = AppSettings
{ appStaticDir :: String
-- ^ Directory from which to serve static files.
, appDatabaseConf :: PostgresConf
-- ^ Configuration settings for accessing the database.
, appRoot :: Maybe Text
-- ^ Base for all generated URLs. If @Nothing@, determined
-- from the request headers.
, appHost :: HostPreference
-- ^ Host/interface the server should bind to.
, appPort :: Int
-- ^ Port to listen on
, appIpFromHeader :: Bool
-- ^ Get the IP address from the header when logging. Useful when sitting
-- behind a reverse proxy.
, appDetailedRequestLogging :: Bool
-- ^ Use detailed request logging system
, appShouldLogAll :: Bool
-- ^ Should all log messages be displayed?
, appReloadTemplates :: Bool
-- ^ Use the reload version of templates
, appMutableStatic :: Bool
-- ^ Assume that files in the static dir may change after compilation
, appSkipCombining :: Bool
-- ^ Perform no stylesheet/script combining
-- Example app-specific configuration values.
, appCopyright :: Text
-- ^ Copyright text to appear in the footer of the page
, appAnalytics :: Maybe Text
-- ^ Google Analytics code
, appAuthDummyLogin :: Bool
-- ^ Indicate if auth dummy login should be enabled.
}
instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do
let defaultDev =
#ifdef DEVELOPMENT
True
#else
False
#endif
appStaticDir <- o .: "static-dir"
appDatabaseConf <- o .: "database"
appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host"
appPort <- o .: "port"
appIpFromHeader <- o .: "ip-from-header"
dev <- o .:? "development" .!= defaultDev
appDetailedRequestLogging <- o .:? "detailed-logging" .!= dev
appShouldLogAll <- o .:? "should-log-all" .!= dev
appReloadTemplates <- o .:? "reload-templates" .!= dev
appMutableStatic <- o .:? "mutable-static" .!= dev
appSkipCombining <- o .:? "skip-combining" .!= dev
appCopyright <- o .: "copyright"
appAnalytics <- o .:? "analytics"
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= dev
return AppSettings {..}
-- | Settings for 'widgetFile', such as which template languages to support and
-- default Hamlet settings.
--
-- For more information on modifying behavior, see:
--
-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile
widgetFileSettings :: WidgetFileSettings
widgetFileSettings = def
-- | How static files should be combined.
combineSettings :: CombineSettings
combineSettings = def
-- The rest of this file contains settings which rarely need changing by a
-- user.
widgetFile :: String -> Q Exp
widgetFile = (if appReloadTemplates compileTimeAppSettings
then widgetFileReload
else widgetFileNoReload)
widgetFileSettings
-- | Raw bytes at compile time of @config/settings.yml@
configSettingsYmlBS :: ByteString
configSettingsYmlBS = $(embedFile configSettingsYml)