├── .gitignore ├── .gitlab-ci.yml ├── Dockerfile ├── Dockerfile.base ├── Makefile ├── README.md ├── app ├── DevelMain.hs ├── devel.hs └── main.hs ├── chart ├── .helmignore ├── Chart.yaml ├── templates │ ├── NOTES.txt │ ├── _helpers.tpl │ ├── deployment.yaml │ ├── ingress.yaml │ └── service.yaml ├── values.yaml └── values │ └── production.yaml ├── config ├── favicon.ico ├── keter.yml ├── models ├── robots.txt ├── routes ├── settings.yml └── test-settings.yml ├── docker-compose.yml ├── entrypoint.sh ├── example_kube_specs ├── README.md ├── deployment_template.yaml └── service_template.yaml ├── myapp.cabal ├── package.yaml ├── src ├── Application.hs ├── Foundation.hs ├── Handler │ ├── Comment.hs │ ├── Common.hs │ ├── Home.hs │ └── Profile.hs ├── Import.hs ├── Import │ └── NoFoundation.hs ├── Model.hs ├── Settings.hs └── Settings │ └── StaticFiles.hs ├── stack-native.yaml ├── stack.yaml ├── 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.julius ├── homepage.lucius └── profile.hamlet └── test ├── Handler ├── CommentSpec.hs ├── CommonSpec.hs ├── HomeSpec.hs └── ProfileSpec.hs ├── Spec.hs └── TestImport.hs /.gitignore: -------------------------------------------------------------------------------- 1 | *sqlite3* 2 | .stack-work 3 | config/client_session_key.aes 4 | -------------------------------------------------------------------------------- /.gitlab-ci.yml: -------------------------------------------------------------------------------- 1 | image: registry.gitlab.fpcomplete.com/fpco/default-build-image:4330 2 | 3 | stages: 4 | - build 5 | - deploy 6 | 7 | build-and-push: 8 | stage: build 9 | script: 10 | - make build-ci-image 11 | - docker login -u gitlab-ci-token -p "${CI_BUILD_TOKEN}" "${CI_REGISTRY}" 12 | - docker push "${CI_REGISTRY_IMAGE}:${CI_PIPELINE_ID}" 13 | 14 | deploy_prod: 15 | stage: deploy 16 | script: 17 | - make deploy 18 | environment: 19 | name: production 20 | url: https://k8s-haskell-webinar.fpcomplete.com 21 | when: manual 22 | only: 23 | - master 24 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM fpco/stack-build:lts-9.9 as build 2 | 3 | RUN mkdir /opt/build 4 | COPY . /opt/build 5 | 6 | VOLUME /tmp/stackroot 7 | 8 | RUN cd /opt/build && stack --stack-root=/tmp/stackroot build --system-ghc 9 | 10 | FROM fpco/pid1 11 | RUN mkdir -p /opt/app 12 | ARG BINARY_PATH 13 | WORKDIR /opt/app 14 | 15 | RUN apt-get update && apt-get install -y \ 16 | ca-certificates \ 17 | libgmp-dev 18 | 19 | COPY entrypoint.sh /usr/local/bin/entrypoint.sh 20 | ENTRYPOINT ["/usr/local/bin/entrypoint.sh"] 21 | 22 | COPY --from=build /opt/build/.stack-work/install/x86_64-linux/lts-9.9/8.0.2/bin . 23 | COPY static /opt/app/static 24 | COPY config /opt/app/config 25 | 26 | CMD ["/opt/app/myapp"] 27 | 28 | -------------------------------------------------------------------------------- /Dockerfile.base: -------------------------------------------------------------------------------- 1 | FROM fpco/pid1 2 | 3 | RUN mkdir -p /opt/app 4 | WORKDIR /opt/app 5 | 6 | RUN apt-get update && apt-get install -y \ 7 | ca-certificates \ 8 | libgmp-dev 9 | 10 | COPY entrypoint.sh /usr/local/bin/entrypoint.sh 11 | ENTRYPOINT ["/usr/local/bin/entrypoint.sh"] 12 | 13 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: build run help build-base build-stack-native run-native 2 | 3 | DEFAULT_GOAL: help 4 | 5 | PROJECT_NAME ?= $(shell grep "^name" myapp.cabal | cut -d " " -f17) 6 | VERSION ?= $(shell grep "^version:" myapp.cabal | cut -d " " -f14) 7 | RESOLVER ?= $(shell grep "^resolver:" stack.yaml | cut -d " " -f2) 8 | GHC_VERSION ?= $(shell stack ghc -- --version | cut -d " " -f8) 9 | ARCH=$(shell uname -m) 10 | 11 | export LOCAL_USER_ID ?= $(shell id -u $$USER) 12 | export BINARY_ROOT = $(shell stack path --local-install-root) 13 | export BINARY_PATH = $(shell echo ${BINARY_ROOT}/bin/${PROJECT_NAME}) 14 | export BINARY_PATH_RELATIVE = $(shell BINARY_PATH=${BINARY_PATH} python -c "import os; p = os.environ['BINARY_PATH']; print os.path.relpath(p).strip()") 15 | 16 | IMAGE_NAME=gitlab.fpcomplete.com/fpco-mirors/haskell-multi-docker-example 17 | 18 | ## Build binary and docker images 19 | build: 20 | @BINARY_PATH=${BINARY_PATH_RELATIVE} docker-compose build 21 | 22 | ## Build docker image. Used in CI/CD 23 | build-ci-image: 24 | @docker build --build-arg BINARY_PATH=${BINARY_PATH_RELATIVE} -t "${CI_REGISTRY_IMAGE}:${CI_PIPELINE_ID}" . 25 | 26 | ## Run the app 27 | run: 28 | @LOCAL_USER_ID=${LOCAL_USER_ID} docker-compose up 29 | 30 | ## Builds base image used for `stack image container` 31 | build-base: 32 | @docker build -t fpco/myapp-base -f Dockerfile.base . 33 | 34 | ## Builds app using stack-native.yaml 35 | build-stack-native: build-base 36 | @stack --stack-yaml stack-native.yaml build 37 | @stack --stack-yaml stack-native.yaml image container 38 | 39 | ## Run container built by `stack image container` 40 | run-stack-native: 41 | @docker run -p 3000:3000 -it -w /opt/app ${IMAGE_NAME} myapp 42 | 43 | ## Deploy helm chart 44 | deploy: 45 | @echo "Deploying build pipeline: ${CI_PIPELINE_ID}" 46 | @helm upgrade \ 47 | --install myapp chart \ 48 | -f chart/values/${CI_ENVIRONMENT_NAME}.yaml \ 49 | --set image.tag="${CI_PIPELINE_ID}" 50 | 51 | ## Show help screen. 52 | help: 53 | @echo "Please use \`make ' where is one of\n\n" 54 | @awk '/^[a-zA-Z\-\_0-9]+:/ { \ 55 | helpMessage = match(lastLine, /^## (.*)/); \ 56 | if (helpMessage) { \ 57 | helpCommand = substr($$1, 0, index($$1, ":")-1); \ 58 | helpMessage = substr(lastLine, RSTART + 3, RLENGTH); \ 59 | printf "%-30s %s\n", helpCommand, helpMessage; \ 60 | } \ 61 | } \ 62 | { lastLine = $$0 }' $(MAKEFILE_LIST) 63 | 64 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Example project showcasing how to build a Haskell application using docker 2 | 3 | The repo covers: 4 | 5 | 1. How to build a docker image natively on Linux 6 | 2. How to build a docker image on a non-Linux platform 7 | 3. How to use `stack image container` 8 | 4. How to have proper permission within the container using `entrypoiton.sh` and `fpco/pid1`. 9 | 10 | -------------------------------------------------------------------------------- /app/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 | -------------------------------------------------------------------------------- /app/devel.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PackageImports #-} 2 | import "myapp" Application (develMain) 3 | import Prelude (IO) 4 | 5 | main :: IO () 6 | main = develMain 7 | -------------------------------------------------------------------------------- /app/main.hs: -------------------------------------------------------------------------------- 1 | import Prelude (IO) 2 | import Application (appMain) 3 | 4 | main :: IO () 5 | main = appMain 6 | -------------------------------------------------------------------------------- /chart/.helmignore: -------------------------------------------------------------------------------- 1 | # Patterns to ignore when building packages. 2 | # This supports shell glob matching, relative path matching, and 3 | # negation (prefixed with !). Only one pattern per line. 4 | .DS_Store 5 | # Common VCS dirs 6 | .git/ 7 | .gitignore 8 | .bzr/ 9 | .bzrignore 10 | .hg/ 11 | .hgignore 12 | .svn/ 13 | # Common backup files 14 | *.swp 15 | *.bak 16 | *.tmp 17 | *~ 18 | # Various IDEs 19 | .project 20 | .idea/ 21 | *.tmproj 22 | -------------------------------------------------------------------------------- /chart/Chart.yaml: -------------------------------------------------------------------------------- 1 | apiVersion: v1 2 | description: An example Helm chart for Kubernetes 3 | name: myapp 4 | version: 0.1.0 5 | -------------------------------------------------------------------------------- /chart/templates/NOTES.txt: -------------------------------------------------------------------------------- 1 | 1. Get the application URL by running these commands: 2 | {{- if .Values.ingress.enabled }} 3 | {{- range .Values.ingress.hosts }} 4 | http://{{ . }} 5 | {{- end }} 6 | {{- else if contains "NodePort" .Values.service.type }} 7 | export NODE_PORT=$(kubectl get --namespace {{ .Release.Namespace }} -o jsonpath="{.spec.ports[0].nodePort}" services {{ template "chart.fullname" . }}) 8 | export NODE_IP=$(kubectl get nodes --namespace {{ .Release.Namespace }} -o jsonpath="{.items[0].status.addresses[0].address}") 9 | echo http://$NODE_IP:$NODE_PORT 10 | {{- else if contains "LoadBalancer" .Values.service.type }} 11 | NOTE: It may take a few minutes for the LoadBalancer IP to be available. 12 | You can watch the status of by running 'kubectl get svc -w {{ template "chart.fullname" . }}' 13 | export SERVICE_IP=$(kubectl get svc --namespace {{ .Release.Namespace }} {{ template "chart.fullname" . }} -o jsonpath='{.status.loadBalancer.ingress[0].ip}') 14 | echo http://$SERVICE_IP:{{ .Values.service.externalPort }} 15 | {{- else if contains "ClusterIP" .Values.service.type }} 16 | export POD_NAME=$(kubectl get pods --namespace {{ .Release.Namespace }} -l "app={{ template "chart.name" . }},release={{ .Release.Name }}" -o jsonpath="{.items[0].metadata.name}") 17 | echo "Visit http://127.0.0.1:8080 to use your application" 18 | kubectl port-forward $POD_NAME 8080:{{ .Values.service.internalPort }} 19 | {{- end }} 20 | -------------------------------------------------------------------------------- /chart/templates/_helpers.tpl: -------------------------------------------------------------------------------- 1 | {{/* vim: set filetype=mustache: */}} 2 | {{/* 3 | Expand the name of the chart. 4 | */}} 5 | {{- define "chart.name" -}} 6 | {{- default .Chart.Name .Values.nameOverride | trunc 63 | trimSuffix "-" -}} 7 | {{- end -}} 8 | 9 | {{/* 10 | Create a default fully qualified app name. 11 | We truncate at 63 chars because some Kubernetes name fields are limited to this (by the DNS naming spec). 12 | */}} 13 | {{- define "chart.fullname" -}} 14 | {{- $name := default .Chart.Name .Values.nameOverride -}} 15 | {{- printf "%s-%s" .Release.Name $name | trunc 63 | trimSuffix "-" -}} 16 | {{- end -}} 17 | -------------------------------------------------------------------------------- /chart/templates/deployment.yaml: -------------------------------------------------------------------------------- 1 | apiVersion: extensions/v1beta1 2 | kind: Deployment 3 | metadata: 4 | name: {{ template "chart.fullname" . }} 5 | labels: 6 | app: {{ template "chart.name" . }} 7 | chart: {{ .Chart.Name }}-{{ .Chart.Version | replace "+" "_" }} 8 | release: {{ .Release.Name }} 9 | heritage: {{ .Release.Service }} 10 | spec: 11 | replicas: {{ .Values.replicaCount }} 12 | template: 13 | metadata: 14 | labels: 15 | app: {{ template "chart.name" . }} 16 | release: {{ .Release.Name }} 17 | spec: 18 | imagePullSecrets: 19 | - name: registry-key 20 | containers: 21 | - name: {{ .Chart.Name }} 22 | image: "{{ .Values.image.repository }}:{{ .Values.image.tag }}" 23 | imagePullPolicy: {{ .Values.image.pullPolicy }} 24 | ports: 25 | - containerPort: {{ .Values.service.internalPort }} 26 | livenessProbe: 27 | httpGet: 28 | path: / 29 | port: {{ .Values.service.internalPort }} 30 | readinessProbe: 31 | httpGet: 32 | path: / 33 | port: {{ .Values.service.internalPort }} 34 | resources: 35 | {{ toYaml .Values.resources | indent 12 }} 36 | {{- if .Values.nodeSelector }} 37 | nodeSelector: 38 | {{ toYaml .Values.nodeSelector | indent 8 }} 39 | {{- end }} 40 | -------------------------------------------------------------------------------- /chart/templates/ingress.yaml: -------------------------------------------------------------------------------- 1 | {{- if .Values.ingress.enabled -}} 2 | {{- $serviceName := include "chart.fullname" . -}} 3 | {{- $servicePort := .Values.service.externalPort -}} 4 | apiVersion: extensions/v1beta1 5 | kind: Ingress 6 | metadata: 7 | name: {{ template "chart.fullname" . }} 8 | labels: 9 | app: {{ template "chart.name" . }} 10 | chart: {{ .Chart.Name }}-{{ .Chart.Version | replace "+" "_" }} 11 | release: {{ .Release.Name }} 12 | heritage: {{ .Release.Service }} 13 | annotations: 14 | {{- range $key, $value := .Values.ingress.annotations }} 15 | {{ $key }}: {{ $value | quote }} 16 | {{- end }} 17 | spec: 18 | rules: 19 | {{- range $host := .Values.ingress.hosts }} 20 | - host: {{ $host }} 21 | http: 22 | paths: 23 | - path: / 24 | backend: 25 | serviceName: {{ $serviceName }} 26 | servicePort: {{ $servicePort }} 27 | {{- end -}} 28 | {{- if .Values.ingress.tls }} 29 | tls: 30 | {{ toYaml .Values.ingress.tls | indent 4 }} 31 | {{- end -}} 32 | {{- end -}} 33 | -------------------------------------------------------------------------------- /chart/templates/service.yaml: -------------------------------------------------------------------------------- 1 | apiVersion: v1 2 | kind: Service 3 | metadata: 4 | name: {{ template "chart.fullname" . }} 5 | labels: 6 | app: {{ template "chart.name" . }} 7 | chart: {{ .Chart.Name }}-{{ .Chart.Version | replace "+" "_" }} 8 | release: {{ .Release.Name }} 9 | heritage: {{ .Release.Service }} 10 | spec: 11 | type: {{ .Values.service.type }} 12 | ports: 13 | - port: {{ .Values.service.externalPort }} 14 | targetPort: {{ .Values.service.internalPort }} 15 | protocol: TCP 16 | name: {{ .Values.service.name }} 17 | selector: 18 | app: {{ template "chart.name" . }} 19 | release: {{ .Release.Name }} 20 | -------------------------------------------------------------------------------- /chart/values.yaml: -------------------------------------------------------------------------------- 1 | replicaCount: 1 2 | image: 3 | repository: registry.gitlab.fpcomplete.com/fpco-mirrors/haskell-multi-docker-example 4 | tag: latest 5 | pullPolicy: IfNotPresent 6 | service: 7 | name: myapp 8 | type: ClusterIP 9 | externalPort: 80 10 | internalPort: 3000 11 | ingress: 12 | enabled: false 13 | # Used to create an Ingress record. 14 | hosts: 15 | - myapp.example.com 16 | annotations: 17 | # kubernetes.io/ingress.class: nginx 18 | # kubernetes.io/tls-acme: "true" 19 | tls: 20 | # Secrets must be manually created in the namespace. 21 | # - secretName: chart-example-tls 22 | # hosts: 23 | # - chart-example.local 24 | resources: {} 25 | # We usually recommend not to specify default resources and to leave this as a conscious 26 | # choice for the user. This also increases chances charts run on environments with little 27 | # resources, such as Minikube. If you do want to specify resources, uncomment the following 28 | # lines, adjust them as necessary, and remove the curly braces after 'resources:'. 29 | # limits: 30 | # cpu: 100m 31 | # memory: 128Mi 32 | # requests: 33 | # cpu: 100m 34 | # memory: 128Mi 35 | -------------------------------------------------------------------------------- /chart/values/production.yaml: -------------------------------------------------------------------------------- 1 | ingress: 2 | enabled: true 3 | hosts: 4 | - k8s-haskell-webinar.fpcomplete.com 5 | annotations: 6 | kubernetes.io/ingress.class: nginx 7 | kubernetes.io/tls-acme: "true" 8 | tls: 9 | # Secrets must be manually created in the namespace. 10 | - secretName: k8s-haskell-webinar-tls 11 | hosts: 12 | - k8s-haskell-webinar.fpcomplete.com 13 | -------------------------------------------------------------------------------- /config/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fpco/haskell-multi-docker-example/0b3c08813a20e20ec60d3a00ecef6d15c125ad8d/config/favicon.ico -------------------------------------------------------------------------------- /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/myapp/myapp 19 | exec: ../dist/bin/myapp 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.myapp.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.myapp.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 | - myapp.com 48 | actions: 49 | - host: www.myapp.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 | -------------------------------------------------------------------------------- /config/models: -------------------------------------------------------------------------------- 1 | User 2 | ident Text 3 | password Text Maybe 4 | UniqueUser ident 5 | deriving Typeable 6 | Email 7 | email Text 8 | userId UserId Maybe 9 | verkey Text Maybe 10 | UniqueEmail email 11 | Comment json -- Adding "json" causes ToJSON and FromJSON instances to be derived. 12 | message Text 13 | userId UserId Maybe 14 | deriving Eq 15 | deriving Show 16 | 17 | -- By default this file is used in Model.hs (which is imported by Foundation.hs) 18 | -------------------------------------------------------------------------------- /config/robots.txt: -------------------------------------------------------------------------------- 1 | User-agent: * 2 | -------------------------------------------------------------------------------- /config/routes: -------------------------------------------------------------------------------- 1 | /static StaticR Static appStatic 2 | /auth AuthR Auth getAuth 3 | 4 | /favicon.ico FaviconR GET 5 | /robots.txt RobotsR GET 6 | 7 | / HomeR GET POST 8 | 9 | /comments CommentR POST 10 | 11 | /profile ProfileR GET 12 | -------------------------------------------------------------------------------- /config/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 | # Optional values with the following production defaults. 14 | # In development, they default to the inverse. 15 | # 16 | # detailed-logging: false 17 | # should-log-all: false 18 | # reload-templates: false 19 | # mutable-static: false 20 | # skip-combining: false 21 | # auth-dummy-login : false 22 | 23 | # 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'") 24 | # See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings 25 | 26 | database: 27 | # See config/test-settings.yml for an override during tests 28 | database: "_env:SQLITE_DATABASE:myapp.sqlite3" 29 | poolsize: "_env:SQLITE_POOLSIZE:10" 30 | 31 | copyright: Insert copyright statement here 32 | #analytics: UA-YOURCODE 33 | -------------------------------------------------------------------------------- /config/test-settings.yml: -------------------------------------------------------------------------------- 1 | database: 2 | # NOTE: By design, this setting prevents the SQLITE_DATABASE 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:SQLITE_DATABASE:myapp_test.sqlite3" 9 | database: myapp_test.sqlite3 10 | 11 | auth-dummy-login: true 12 | -------------------------------------------------------------------------------- /docker-compose.yml: -------------------------------------------------------------------------------- 1 | version: '2' 2 | 3 | services: 4 | myapp: 5 | build: 6 | context: . 7 | args: 8 | - BINARY_PATH 9 | image: gitlab.fpcomplete.com/fpco-mirors/haskell-multi-docker-example 10 | environment: 11 | - LOCAL_USER_ID=${LOCAL_USER_ID} 12 | ports: 13 | - 3000:3000 14 | 15 | -------------------------------------------------------------------------------- /entrypoint.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Add local user 4 | # Either use the LOCAL_USER_ID if passed in at runtime or 5 | # fallback 6 | 7 | USER_ID=${LOCAL_USER_ID:-9001} 8 | APP_DIR=${APP_DIR:-/opt/app} 9 | 10 | echo "Starting with UID : $USER_ID" 11 | useradd --shell /bin/bash -u $USER_ID -o -c "" -m user 12 | export HOME=/home/user 13 | 14 | # set correct permissions on APP_DIR and subfolders 15 | chown -R user. $APP_DIR 16 | 17 | exec /sbin/pid1 -u user -g user "$@" 18 | 19 | -------------------------------------------------------------------------------- /example_kube_specs/README.md: -------------------------------------------------------------------------------- 1 | The kube specs located here are used only as a first example of how to deploy a docker 2 | image to a cluster but we then move on and show how to deploy a helm chart. 3 | -------------------------------------------------------------------------------- /example_kube_specs/deployment_template.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | apiVersion: extensions/v1beta1 3 | kind: Deployment 4 | metadata: 5 | name: myapp 6 | spec: 7 | template: 8 | metadata: 9 | labels: 10 | app: myapp 11 | spec: 12 | imagePullSecrets: 13 | - name: registry-key 14 | containers: 15 | - name: myapp 16 | image: "${DEPLOYMENT_IMAGE}" 17 | imagePullPolicy: Always 18 | ports: 19 | - name: http 20 | containerPort: 3000 21 | command: ["/opt/app/myapp"] 22 | workingDir: /opt/app 23 | readinessProbe: 24 | httpGet: 25 | path: / 26 | port: 3000 27 | livenessProbe: 28 | httpGet: 29 | path: / 30 | port: 3000 31 | -------------------------------------------------------------------------------- /example_kube_specs/service_template.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | apiVersion: v1 3 | kind: Service 4 | metadata: 5 | name: myapp 6 | labels: 7 | app: myapp 8 | spec: 9 | ports: 10 | - name: http 11 | port: 80 12 | targetPort: http 13 | selector: 14 | app: myapp 15 | type: LoadBalancer 16 | -------------------------------------------------------------------------------- /myapp.cabal: -------------------------------------------------------------------------------- 1 | -- This file has been generated from package.yaml by hpack version 0.28.2. 2 | -- 3 | -- see: https://github.com/sol/hpack 4 | -- 5 | -- hash: fd2713a9ad1e9c341d30a10fc2898f4215b986a956e4720930c22b5acf78c40f 6 | 7 | name: myapp 8 | version: 0.0.0 9 | build-type: Simple 10 | cabal-version: >= 1.10 11 | 12 | flag dev 13 | description: Turn on development settings, like auto-reload templates. 14 | manual: False 15 | default: False 16 | 17 | flag library-only 18 | description: Build for use with "yesod devel" 19 | manual: False 20 | default: False 21 | 22 | library 23 | hs-source-dirs: 24 | src 25 | build-depends: 26 | aeson >=0.6 && <1.3 27 | , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 28 | , bytestring >=0.9 && <0.11 29 | , case-insensitive 30 | , classy-prelude >=0.10.2 31 | , classy-prelude-conduit >=0.10.2 32 | , classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1 33 | , conduit >=1.0 && <2.0 34 | , containers 35 | , data-default 36 | , directory >=1.1 && <1.4 37 | , fast-logger >=2.2 && <2.5 38 | , file-embed 39 | , hjsmin >=0.1 && <0.3 40 | , http-conduit >=2.1 && <2.3 41 | , monad-control >=0.3 && <1.1 42 | , monad-logger >=0.3 && <0.4 43 | , persistent >=2.0 && <2.8 44 | , persistent-sqlite >=2.6.2 && <2.8 45 | , persistent-template >=2.0 && <2.8 46 | , safe 47 | , shakespeare >=2.0 && <2.1 48 | , template-haskell 49 | , text >=0.11 && <2.0 50 | , time 51 | , unordered-containers 52 | , vector 53 | , wai 54 | , wai-extra >=3.0 && <3.1 55 | , wai-logger >=2.2 && <2.4 56 | , warp >=3.0 && <3.3 57 | , yaml >=0.8 && <0.9 58 | , yesod >=1.4.3 && <1.5 59 | , yesod-auth >=1.4.0 && <1.5 60 | , yesod-core >=1.4.30 && <1.5 61 | , yesod-form >=1.4.0 && <1.5 62 | , yesod-static >=1.4.0.3 && <1.6 63 | if (flag(dev)) || (flag(library-only)) 64 | ghc-options: -Wall -fwarn-tabs -O0 65 | cpp-options: -DDEVELOPMENT 66 | else 67 | ghc-options: -Wall -fwarn-tabs -O2 68 | exposed-modules: 69 | Application 70 | Foundation 71 | Handler.Comment 72 | Handler.Common 73 | Handler.Home 74 | Handler.Profile 75 | Import 76 | Import.NoFoundation 77 | Model 78 | Settings 79 | Settings.StaticFiles 80 | other-modules: 81 | Paths_myapp 82 | default-language: Haskell2010 83 | 84 | executable myapp 85 | main-is: main.hs 86 | hs-source-dirs: 87 | app 88 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 89 | build-depends: 90 | aeson >=0.6 && <1.3 91 | , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 92 | , bytestring >=0.9 && <0.11 93 | , case-insensitive 94 | , classy-prelude >=0.10.2 95 | , classy-prelude-conduit >=0.10.2 96 | , classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1 97 | , conduit >=1.0 && <2.0 98 | , containers 99 | , data-default 100 | , directory >=1.1 && <1.4 101 | , fast-logger >=2.2 && <2.5 102 | , file-embed 103 | , hjsmin >=0.1 && <0.3 104 | , http-conduit >=2.1 && <2.3 105 | , monad-control >=0.3 && <1.1 106 | , monad-logger >=0.3 && <0.4 107 | , myapp 108 | , persistent >=2.0 && <2.8 109 | , persistent-sqlite >=2.6.2 && <2.8 110 | , persistent-template >=2.0 && <2.8 111 | , safe 112 | , shakespeare >=2.0 && <2.1 113 | , template-haskell 114 | , text >=0.11 && <2.0 115 | , time 116 | , unordered-containers 117 | , vector 118 | , wai 119 | , wai-extra >=3.0 && <3.1 120 | , wai-logger >=2.2 && <2.4 121 | , warp >=3.0 && <3.3 122 | , yaml >=0.8 && <0.9 123 | , yesod >=1.4.3 && <1.5 124 | , yesod-auth >=1.4.0 && <1.5 125 | , yesod-core >=1.4.30 && <1.5 126 | , yesod-form >=1.4.0 && <1.5 127 | , yesod-static >=1.4.0.3 && <1.6 128 | if flag(library-only) 129 | buildable: False 130 | other-modules: 131 | DevelMain 132 | Paths_myapp 133 | default-language: Haskell2010 134 | 135 | test-suite test 136 | type: exitcode-stdio-1.0 137 | main-is: Spec.hs 138 | hs-source-dirs: 139 | test 140 | ghc-options: -Wall 141 | build-depends: 142 | aeson >=0.6 && <1.3 143 | , base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 144 | , bytestring >=0.9 && <0.11 145 | , case-insensitive 146 | , classy-prelude >=0.10.2 147 | , classy-prelude-conduit >=0.10.2 148 | , classy-prelude-yesod >=0.10.2 && <1.0 || >=1.1 149 | , conduit >=1.0 && <2.0 150 | , containers 151 | , data-default 152 | , directory >=1.1 && <1.4 153 | , fast-logger >=2.2 && <2.5 154 | , file-embed 155 | , hjsmin >=0.1 && <0.3 156 | , hspec >=2.0.0 157 | , http-conduit >=2.1 && <2.3 158 | , microlens 159 | , monad-control >=0.3 && <1.1 160 | , monad-logger >=0.3 && <0.4 161 | , myapp 162 | , persistent >=2.0 && <2.8 163 | , persistent-sqlite >=2.6.2 && <2.8 164 | , persistent-template >=2.0 && <2.8 165 | , safe 166 | , shakespeare >=2.0 && <2.1 167 | , template-haskell 168 | , text >=0.11 && <2.0 169 | , time 170 | , unordered-containers 171 | , vector 172 | , wai 173 | , wai-extra >=3.0 && <3.1 174 | , wai-logger >=2.2 && <2.4 175 | , warp >=3.0 && <3.3 176 | , yaml >=0.8 && <0.9 177 | , yesod >=1.4.3 && <1.5 178 | , yesod-auth >=1.4.0 && <1.5 179 | , yesod-core >=1.4.30 && <1.5 180 | , yesod-form >=1.4.0 && <1.5 181 | , yesod-static >=1.4.0.3 && <1.6 182 | , yesod-test 183 | other-modules: 184 | Handler.CommentSpec 185 | Handler.CommonSpec 186 | Handler.HomeSpec 187 | Handler.ProfileSpec 188 | TestImport 189 | Paths_myapp 190 | default-language: Haskell2010 191 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: myapp 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 | - yesod >=1.4.3 && <1.5 14 | - yesod-core >=1.4.30 && <1.5 15 | - yesod-auth >=1.4.0 && <1.5 16 | - yesod-static >=1.4.0.3 && <1.6 17 | - yesod-form >=1.4.0 && <1.5 18 | - classy-prelude >=0.10.2 19 | - classy-prelude-conduit >=0.10.2 20 | - bytestring >=0.9 && <0.11 21 | - text >=0.11 && <2.0 22 | - persistent >=2.0 && <2.8 23 | - persistent-sqlite >=2.6.2 && <2.8 24 | - persistent-template >=2.0 && <2.8 25 | - template-haskell 26 | - shakespeare >=2.0 && <2.1 27 | - hjsmin >=0.1 && <0.3 28 | - monad-control >=0.3 && <1.1 29 | - wai-extra >=3.0 && <3.1 30 | - yaml >=0.8 && <0.9 31 | - http-conduit >=2.1 && <2.3 32 | - directory >=1.1 && <1.4 33 | - warp >=3.0 && <3.3 34 | - data-default 35 | - aeson >=0.6 && <1.3 36 | - conduit >=1.0 && <2.0 37 | - monad-logger >=0.3 && <0.4 38 | - fast-logger >=2.2 && <2.5 39 | - wai-logger >=2.2 && <2.4 40 | - file-embed 41 | - safe 42 | - unordered-containers 43 | - containers 44 | - vector 45 | - time 46 | - case-insensitive 47 | - wai 48 | 49 | # The library contains all of our application code. The executable 50 | # defined below is just a thin wrapper. 51 | library: 52 | source-dirs: src 53 | when: 54 | - condition: (flag(dev)) || (flag(library-only)) 55 | then: 56 | ghc-options: 57 | - -Wall 58 | - -fwarn-tabs 59 | - -O0 60 | cpp-options: -DDEVELOPMENT 61 | else: 62 | ghc-options: 63 | - -Wall 64 | - -fwarn-tabs 65 | - -O2 66 | 67 | # Runnable executable for our application 68 | executables: 69 | myapp: 70 | main: main.hs 71 | source-dirs: app 72 | ghc-options: 73 | - -threaded 74 | - -rtsopts 75 | - -with-rtsopts=-N 76 | dependencies: 77 | - myapp 78 | when: 79 | - condition: flag(library-only) 80 | buildable: false 81 | 82 | # Test suite 83 | tests: 84 | test: 85 | main: Spec.hs 86 | source-dirs: test 87 | ghc-options: -Wall 88 | dependencies: 89 | - myapp 90 | - hspec >=2.0.0 91 | - yesod-test 92 | - microlens 93 | 94 | # Define flags used by "yesod devel" to make compilation faster 95 | flags: 96 | library-only: 97 | description: Build for use with "yesod devel" 98 | manual: false 99 | default: false 100 | dev: 101 | description: Turn on development settings, like auto-reload templates. 102 | manual: false 103 | default: false 104 | -------------------------------------------------------------------------------- /src/Application.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# OPTIONS_GHC -fno-warn-orphans #-} 8 | module Application 9 | ( getApplicationDev 10 | , appMain 11 | , develMain 12 | , makeFoundation 13 | , makeLogWare 14 | -- * for DevelMain 15 | , getApplicationRepl 16 | , shutdownApp 17 | -- * for GHCI 18 | , handler 19 | , db 20 | ) where 21 | 22 | import Control.Monad.Logger (liftLoc, runLoggingT) 23 | import Database.Persist.Sqlite (createSqlitePool, runSqlPool, 24 | sqlDatabase, sqlPoolSize) 25 | import Import 26 | import Language.Haskell.TH.Syntax (qLocation) 27 | import Network.Wai (Middleware) 28 | import Network.Wai.Handler.Warp (Settings, defaultSettings, 29 | defaultShouldDisplayException, 30 | runSettings, setHost, 31 | setOnException, setPort, getPort) 32 | import Network.Wai.Middleware.RequestLogger (Destination (Logger), 33 | IPAddrSource (..), 34 | OutputFormat (..), destination, 35 | mkRequestLogger, outputFormat) 36 | import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, 37 | toLogStr) 38 | 39 | -- Import all relevant handler modules here. 40 | -- Don't forget to add new modules to your cabal file! 41 | import Handler.Common 42 | import Handler.Home 43 | import Handler.Comment 44 | import Handler.Profile 45 | 46 | -- This line actually creates our YesodDispatch instance. It is the second half 47 | -- of the call to mkYesodData which occurs in Foundation.hs. Please see the 48 | -- comments there for more details. 49 | mkYesodDispatch "App" resourcesApp 50 | 51 | -- | This function allocates resources (such as a database connection pool), 52 | -- performs initialization and returns a foundation datatype value. This is also 53 | -- the place to put your migrate statements to have automatic database 54 | -- migrations handled by Yesod. 55 | makeFoundation :: AppSettings -> IO App 56 | makeFoundation appSettings = do 57 | -- Some basic initializations: HTTP connection manager, logger, and static 58 | -- subsite. 59 | appHttpManager <- newManager 60 | appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger 61 | appStatic <- 62 | (if appMutableStatic appSettings then staticDevel else static) 63 | (appStaticDir appSettings) 64 | 65 | -- We need a log function to create a connection pool. We need a connection 66 | -- pool to create our foundation. And we need our foundation to get a 67 | -- logging function. To get out of this loop, we initially create a 68 | -- temporary foundation without a real connection pool, get a log function 69 | -- from there, and then create the real foundation. 70 | let mkFoundation appConnPool = App {..} 71 | -- The App {..} syntax is an example of record wild cards. For more 72 | -- information, see: 73 | -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html 74 | tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" 75 | logFunc = messageLoggerSource tempFoundation appLogger 76 | 77 | -- Create the database connection pool 78 | pool <- flip runLoggingT logFunc $ createSqlitePool 79 | (sqlDatabase $ appDatabaseConf appSettings) 80 | (sqlPoolSize $ appDatabaseConf appSettings) 81 | 82 | -- Perform database migration using our application's logging settings. 83 | runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc 84 | 85 | -- Return the foundation 86 | return $ mkFoundation pool 87 | 88 | -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and 89 | -- applying some additional middlewares. 90 | makeApplication :: App -> IO Application 91 | makeApplication foundation = do 92 | logWare <- makeLogWare foundation 93 | -- Create the WAI application and apply middlewares 94 | appPlain <- toWaiAppPlain foundation 95 | return $ logWare $ defaultMiddlewaresNoLogging appPlain 96 | 97 | makeLogWare :: App -> IO Middleware 98 | makeLogWare foundation = 99 | mkRequestLogger def 100 | { outputFormat = 101 | if appDetailedRequestLogging $ appSettings foundation 102 | then Detailed True 103 | else Apache 104 | (if appIpFromHeader $ appSettings foundation 105 | then FromFallback 106 | else FromSocket) 107 | , destination = Logger $ loggerSet $ appLogger foundation 108 | } 109 | 110 | 111 | -- | Warp settings for the given foundation value. 112 | warpSettings :: App -> Settings 113 | warpSettings foundation = 114 | setPort (appPort $ appSettings foundation) 115 | $ setHost (appHost $ appSettings foundation) 116 | $ setOnException (\_req e -> 117 | when (defaultShouldDisplayException e) $ messageLoggerSource 118 | foundation 119 | (appLogger foundation) 120 | $(qLocation >>= liftLoc) 121 | "yesod" 122 | LevelError 123 | (toLogStr $ "Exception from Warp: " ++ show e)) 124 | defaultSettings 125 | 126 | -- | For yesod devel, return the Warp settings and WAI Application. 127 | getApplicationDev :: IO (Settings, Application) 128 | getApplicationDev = do 129 | settings <- getAppSettings 130 | foundation <- makeFoundation settings 131 | wsettings <- getDevSettings $ warpSettings foundation 132 | app <- makeApplication foundation 133 | return (wsettings, app) 134 | 135 | getAppSettings :: IO AppSettings 136 | getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv 137 | 138 | -- | main function for use by yesod devel 139 | develMain :: IO () 140 | develMain = develMainHelper getApplicationDev 141 | 142 | -- | The @main@ function for an executable running this site. 143 | appMain :: IO () 144 | appMain = do 145 | -- Get the settings from all relevant sources 146 | settings <- loadYamlSettingsArgs 147 | -- fall back to compile-time values, set to [] to require values at runtime 148 | [configSettingsYmlValue] 149 | 150 | -- allow environment variables to override 151 | useEnv 152 | 153 | -- Generate the foundation from the settings 154 | foundation <- makeFoundation settings 155 | 156 | -- Generate a WAI Application from the foundation 157 | app <- makeApplication foundation 158 | 159 | -- Run the application with Warp 160 | runSettings (warpSettings foundation) app 161 | 162 | 163 | -------------------------------------------------------------- 164 | -- Functions for DevelMain.hs (a way to run the app from GHCi) 165 | -------------------------------------------------------------- 166 | getApplicationRepl :: IO (Int, App, Application) 167 | getApplicationRepl = do 168 | settings <- getAppSettings 169 | foundation <- makeFoundation settings 170 | wsettings <- getDevSettings $ warpSettings foundation 171 | app1 <- makeApplication foundation 172 | return (getPort wsettings, foundation, app1) 173 | 174 | shutdownApp :: App -> IO () 175 | shutdownApp _ = return () 176 | 177 | 178 | --------------------------------------------- 179 | -- Functions for use in development with GHCi 180 | --------------------------------------------- 181 | 182 | -- | Run a handler 183 | handler :: Handler a -> IO a 184 | handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h 185 | 186 | -- | Run DB queries 187 | db :: ReaderT SqlBackend (HandlerT App IO) a -> IO a 188 | db = handler . runDB 189 | -------------------------------------------------------------------------------- /src/Foundation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | 8 | module Foundation where 9 | 10 | import Import.NoFoundation 11 | import Database.Persist.Sql (ConnectionPool, runSqlPool) 12 | import Text.Hamlet (hamletFile) 13 | import Text.Jasmine (minifym) 14 | 15 | -- Used only when in "auth-dummy-login" setting is enabled. 16 | import Yesod.Auth.Dummy 17 | 18 | import Yesod.Auth.OpenId (authOpenId, IdentifierType (Claimed)) 19 | import Yesod.Default.Util (addStaticContentExternal) 20 | import Yesod.Core.Types (Logger) 21 | import qualified Yesod.Core.Unsafe as Unsafe 22 | import qualified Data.CaseInsensitive as CI 23 | import qualified Data.Text.Encoding as TE 24 | 25 | -- | The foundation datatype for your application. This can be a good place to 26 | -- keep settings and values requiring initialization before your application 27 | -- starts running, such as database connections. Every handler will have 28 | -- access to the data present here. 29 | data App = App 30 | { appSettings :: AppSettings 31 | , appStatic :: Static -- ^ Settings for static file serving. 32 | , appConnPool :: ConnectionPool -- ^ Database connection pool. 33 | , appHttpManager :: Manager 34 | , appLogger :: Logger 35 | } 36 | 37 | data MenuItem = MenuItem 38 | { menuItemLabel :: Text 39 | , menuItemRoute :: Route App 40 | , menuItemAccessCallback :: Bool 41 | } 42 | 43 | data MenuTypes 44 | = NavbarLeft MenuItem 45 | | NavbarRight MenuItem 46 | 47 | -- This is where we define all of the routes in our application. For a full 48 | -- explanation of the syntax, please see: 49 | -- http://www.yesodweb.com/book/routing-and-handlers 50 | -- 51 | -- Note that this is really half the story; in Application.hs, mkYesodDispatch 52 | -- generates the rest of the code. Please see the following documentation 53 | -- for an explanation for this split: 54 | -- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules 55 | -- 56 | -- This function also generates the following type synonyms: 57 | -- type Handler = HandlerT App IO 58 | -- type Widget = WidgetT App IO () 59 | mkYesodData "App" $(parseRoutesFile "config/routes") 60 | 61 | -- | A convenient synonym for creating forms. 62 | type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget) 63 | 64 | -- Please see the documentation for the Yesod typeclass. There are a number 65 | -- of settings which can be configured by overriding methods here. 66 | instance Yesod App where 67 | -- Controls the base of generated URLs. For more information on modifying, 68 | -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot 69 | approot = ApprootRequest $ \app req -> 70 | case appRoot $ appSettings app of 71 | Nothing -> getApprootText guessApproot app req 72 | Just root -> root 73 | 74 | -- Store session data on the client in encrypted cookies, 75 | -- default session idle timeout is 120 minutes 76 | makeSessionBackend _ = Just <$> defaultClientSessionBackend 77 | 120 -- timeout in minutes 78 | "config/client_session_key.aes" 79 | 80 | -- Yesod Middleware allows you to run code before and after each handler function. 81 | -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. 82 | -- Some users may also want to add the defaultCsrfMiddleware, which: 83 | -- a) Sets a cookie with a CSRF token in it. 84 | -- b) Validates that incoming write requests include that token in either a header or POST parameter. 85 | -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware 86 | -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. 87 | yesodMiddleware = defaultYesodMiddleware 88 | 89 | defaultLayout widget = do 90 | master <- getYesod 91 | mmsg <- getMessage 92 | 93 | muser <- maybeAuthPair 94 | mcurrentRoute <- getCurrentRoute 95 | 96 | -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. 97 | (title, parents) <- breadcrumbs 98 | 99 | -- Define the menu items of the header. 100 | let menuItems = 101 | [ NavbarLeft $ MenuItem 102 | { menuItemLabel = "Home" 103 | , menuItemRoute = HomeR 104 | , menuItemAccessCallback = True 105 | } 106 | , NavbarLeft $ MenuItem 107 | { menuItemLabel = "Profile" 108 | , menuItemRoute = ProfileR 109 | , menuItemAccessCallback = isJust muser 110 | } 111 | , NavbarRight $ MenuItem 112 | { menuItemLabel = "Login" 113 | , menuItemRoute = AuthR LoginR 114 | , menuItemAccessCallback = isNothing muser 115 | } 116 | , NavbarRight $ MenuItem 117 | { menuItemLabel = "Logout" 118 | , menuItemRoute = AuthR LogoutR 119 | , menuItemAccessCallback = isJust muser 120 | } 121 | ] 122 | 123 | let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems] 124 | let navbarRightMenuItems = [x | NavbarRight x <- menuItems] 125 | 126 | let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x] 127 | let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x] 128 | 129 | -- We break up the default layout into two components: 130 | -- default-layout is the contents of the body tag, and 131 | -- default-layout-wrapper is the entire page. Since the final 132 | -- value passed to hamletToRepHtml cannot be a widget, this allows 133 | -- you to use normal widget features in default-layout. 134 | 135 | pc <- widgetToPageContent $ do 136 | addStylesheet $ StaticR css_bootstrap_css 137 | $(widgetFile "default-layout") 138 | withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") 139 | 140 | -- The page to be redirected to when authentication is required. 141 | authRoute _ = Just $ AuthR LoginR 142 | 143 | -- Routes not requiring authentication. 144 | isAuthorized (AuthR _) _ = return Authorized 145 | isAuthorized CommentR _ = return Authorized 146 | isAuthorized HomeR _ = return Authorized 147 | isAuthorized FaviconR _ = return Authorized 148 | isAuthorized RobotsR _ = return Authorized 149 | isAuthorized (StaticR _) _ = return Authorized 150 | 151 | isAuthorized ProfileR _ = isAuthenticated 152 | 153 | -- This function creates static content files in the static folder 154 | -- and names them based on a hash of their content. This allows 155 | -- expiration dates to be set far in the future without worry of 156 | -- users receiving stale content. 157 | addStaticContent ext mime content = do 158 | master <- getYesod 159 | let staticDir = appStaticDir $ appSettings master 160 | addStaticContentExternal 161 | minifym 162 | genFileName 163 | staticDir 164 | (StaticR . flip StaticRoute []) 165 | ext 166 | mime 167 | content 168 | where 169 | -- Generate a unique filename based on the content itself 170 | genFileName lbs = "autogen-" ++ base64md5 lbs 171 | 172 | -- What messages should be logged. The following includes all messages when 173 | -- in development, and warnings and errors in production. 174 | shouldLog app _source level = 175 | appShouldLogAll (appSettings app) 176 | || level == LevelWarn 177 | || level == LevelError 178 | 179 | makeLogger = return . appLogger 180 | 181 | -- Define breadcrumbs. 182 | instance YesodBreadcrumbs App where 183 | breadcrumb HomeR = return ("Home", Nothing) 184 | breadcrumb (AuthR _) = return ("Login", Just HomeR) 185 | breadcrumb ProfileR = return ("Profile", Just HomeR) 186 | breadcrumb _ = return ("home", Nothing) 187 | 188 | -- How to run database actions. 189 | instance YesodPersist App where 190 | type YesodPersistBackend App = SqlBackend 191 | runDB action = do 192 | master <- getYesod 193 | runSqlPool action $ appConnPool master 194 | instance YesodPersistRunner App where 195 | getDBRunner = defaultGetDBRunner appConnPool 196 | 197 | instance YesodAuth App where 198 | type AuthId App = UserId 199 | 200 | -- Where to send a user after successful login 201 | loginDest _ = HomeR 202 | -- Where to send a user after logout 203 | logoutDest _ = HomeR 204 | -- Override the above two destinations when a Referer: header is present 205 | redirectToReferer _ = True 206 | 207 | authenticate creds = runDB $ do 208 | x <- getBy $ UniqueUser $ credsIdent creds 209 | case x of 210 | Just (Entity uid _) -> return $ Authenticated uid 211 | Nothing -> Authenticated <$> insert User 212 | { userIdent = credsIdent creds 213 | , userPassword = Nothing 214 | } 215 | 216 | -- You can add other plugins like Google Email, email or OAuth here 217 | authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins 218 | -- Enable authDummy login if enabled. 219 | where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app] 220 | 221 | authHttpManager = getHttpManager 222 | 223 | -- | Access function to determine if a user is logged in. 224 | isAuthenticated :: Handler AuthResult 225 | isAuthenticated = do 226 | muid <- maybeAuthId 227 | return $ case muid of 228 | Nothing -> Unauthorized "You must login to access this page" 229 | Just _ -> Authorized 230 | 231 | instance YesodAuthPersist App 232 | 233 | -- This instance is required to use forms. You can modify renderMessage to 234 | -- achieve customized and internationalized form validation messages. 235 | instance RenderMessage App FormMessage where 236 | renderMessage _ _ = defaultFormMessage 237 | 238 | -- Useful when writing code that is re-usable outside of the Handler context. 239 | -- An example is background jobs that send email. 240 | -- This can also be useful for writing code that works across multiple Yesod applications. 241 | instance HasHttpManager App where 242 | getHttpManager = appHttpManager 243 | 244 | unsafeHandler :: App -> Handler a -> IO a 245 | unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger 246 | 247 | -- Note: Some functionality previously present in the scaffolding has been 248 | -- moved to documentation in the Wiki. Following are some hopefully helpful 249 | -- links: 250 | -- 251 | -- https://github.com/yesodweb/yesod/wiki/Sending-email 252 | -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain 253 | -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding 254 | -------------------------------------------------------------------------------- /src/Handler/Comment.hs: -------------------------------------------------------------------------------- 1 | module Handler.Comment where 2 | 3 | import Import 4 | 5 | postCommentR :: Handler Value 6 | postCommentR = do 7 | -- requireJsonBody will parse the request body into the appropriate type, or return a 400 status code if the request JSON is invalid. 8 | -- (The ToJSON and FromJSON instances are derived in the config/models file). 9 | comment <- (requireJsonBody :: Handler Comment) 10 | 11 | -- The YesodAuth instance in Foundation.hs defines the UserId to be the type used for authentication. 12 | maybeCurrentUserId <- maybeAuthId 13 | let comment' = comment { commentUserId = maybeCurrentUserId } 14 | 15 | insertedComment <- runDB $ insertEntity comment' 16 | returnJson insertedComment 17 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /src/Handler/Home.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | module Handler.Home where 7 | 8 | import Import 9 | import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3) 10 | import Text.Julius (RawJS (..)) 11 | 12 | -- Define our data that will be used for creating the form. 13 | data FileForm = FileForm 14 | { fileInfo :: FileInfo 15 | , fileDescription :: Text 16 | } 17 | 18 | -- This is a handler function for the GET request method on the HomeR 19 | -- resource pattern. All of your resource patterns are defined in 20 | -- config/routes 21 | -- 22 | -- The majority of the code you will write in Yesod lives in these handler 23 | -- functions. You can spread them across multiple files if you are so 24 | -- inclined, or create a single monolithic file. 25 | getHomeR :: Handler Html 26 | getHomeR = do 27 | (formWidget, formEnctype) <- generateFormPost sampleForm 28 | let submission = Nothing :: Maybe FileForm 29 | handlerName = "getHomeR" :: Text 30 | defaultLayout $ do 31 | let (commentFormId, commentTextareaId, commentListId) = commentIds 32 | aDomId <- newIdent 33 | setTitle "Welcome To Yesod!" 34 | $(widgetFile "homepage") 35 | 36 | postHomeR :: Handler Html 37 | postHomeR = do 38 | ((result, formWidget), formEnctype) <- runFormPost sampleForm 39 | let handlerName = "postHomeR" :: Text 40 | submission = case result of 41 | FormSuccess res -> Just res 42 | _ -> Nothing 43 | 44 | defaultLayout $ do 45 | let (commentFormId, commentTextareaId, commentListId) = commentIds 46 | aDomId <- newIdent 47 | setTitle "Welcome To Yesod!" 48 | $(widgetFile "homepage") 49 | 50 | sampleForm :: Form FileForm 51 | sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm 52 | <$> fileAFormReq "Choose a file" 53 | <*> areq textField textSettings Nothing 54 | -- Add attributes like the placeholder and CSS classes. 55 | where textSettings = FieldSettings 56 | { fsLabel = "What's on the file?" 57 | , fsTooltip = Nothing 58 | , fsId = Nothing 59 | , fsName = Nothing 60 | , fsAttrs = 61 | [ ("class", "form-control") 62 | , ("placeholder", "File description") 63 | ] 64 | } 65 | 66 | commentIds :: (Text, Text, Text) 67 | commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList") 68 | -------------------------------------------------------------------------------- /src/Handler/Profile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | module Handler.Profile where 7 | 8 | import Import 9 | 10 | getProfileR :: Handler Html 11 | getProfileR = do 12 | (_, user) <- requireAuthPair 13 | defaultLayout $ do 14 | setTitle . toHtml $ userIdent user <> "'s User page" 15 | $(widgetFile "profile") 16 | -------------------------------------------------------------------------------- /src/Import.hs: -------------------------------------------------------------------------------- 1 | module Import 2 | ( module Import 3 | ) where 4 | 5 | import Foundation as Import 6 | import Import.NoFoundation as Import 7 | -------------------------------------------------------------------------------- /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 Model as Import 8 | import Settings as Import 9 | import Settings.StaticFiles as Import 10 | import Yesod.Auth as Import 11 | import Yesod.Core.Types as Import (loggerSet) 12 | import Yesod.Default.Config2 as Import 13 | -------------------------------------------------------------------------------- /src/Model.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE EmptyDataDecls #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE GADTs #-} 4 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE NoImplicitPrelude #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | module Model where 11 | 12 | import ClassyPrelude.Yesod 13 | import Database.Persist.Quasi 14 | 15 | -- You can define all of your database entities in the entities file. 16 | -- You can find more information on persistent and how to declare entities 17 | -- at: 18 | -- http://www.yesodweb.com/book/persistent/ 19 | share [mkPersist sqlSettings, mkMigrate "migrateAll"] 20 | $(persistFileWith lowerCaseSettings "config/models") 21 | -------------------------------------------------------------------------------- /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.Sqlite (SqliteConf) 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, widgetFileNoReload, 24 | widgetFileReload) 25 | 26 | -- | Runtime settings to configure this application. These settings can be 27 | -- loaded from various sources: defaults, environment variables, config files, 28 | -- theoretically even a database. 29 | data AppSettings = AppSettings 30 | { appStaticDir :: String 31 | -- ^ Directory from which to serve static files. 32 | , appDatabaseConf :: SqliteConf 33 | -- ^ Configuration settings for accessing the database. 34 | , appRoot :: Maybe Text 35 | -- ^ Base for all generated URLs. If @Nothing@, determined 36 | -- from the request headers. 37 | , appHost :: HostPreference 38 | -- ^ Host/interface the server should bind to. 39 | , appPort :: Int 40 | -- ^ Port to listen on 41 | , appIpFromHeader :: Bool 42 | -- ^ Get the IP address from the header when logging. Useful when sitting 43 | -- behind a reverse proxy. 44 | 45 | , appDetailedRequestLogging :: Bool 46 | -- ^ Use detailed request logging system 47 | , appShouldLogAll :: Bool 48 | -- ^ Should all log messages be displayed? 49 | , appReloadTemplates :: Bool 50 | -- ^ Use the reload version of templates 51 | , appMutableStatic :: Bool 52 | -- ^ Assume that files in the static dir may change after compilation 53 | , appSkipCombining :: Bool 54 | -- ^ Perform no stylesheet/script combining 55 | 56 | -- Example app-specific configuration values. 57 | , appCopyright :: Text 58 | -- ^ Copyright text to appear in the footer of the page 59 | , appAnalytics :: Maybe Text 60 | -- ^ Google Analytics code 61 | 62 | , appAuthDummyLogin :: Bool 63 | -- ^ Indicate if auth dummy login should be enabled. 64 | } 65 | 66 | instance FromJSON AppSettings where 67 | parseJSON = withObject "AppSettings" $ \o -> do 68 | let defaultDev = 69 | #ifdef DEVELOPMENT 70 | True 71 | #else 72 | False 73 | #endif 74 | appStaticDir <- o .: "static-dir" 75 | appDatabaseConf <- o .: "database" 76 | appRoot <- o .:? "approot" 77 | appHost <- fromString <$> o .: "host" 78 | appPort <- o .: "port" 79 | appIpFromHeader <- o .: "ip-from-header" 80 | 81 | appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev 82 | appShouldLogAll <- o .:? "should-log-all" .!= defaultDev 83 | appReloadTemplates <- o .:? "reload-templates" .!= defaultDev 84 | appMutableStatic <- o .:? "mutable-static" .!= defaultDev 85 | appSkipCombining <- o .:? "skip-combining" .!= defaultDev 86 | 87 | appCopyright <- o .: "copyright" 88 | appAnalytics <- o .:? "analytics" 89 | 90 | appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev 91 | 92 | return AppSettings {..} 93 | 94 | -- | Settings for 'widgetFile', such as which template languages to support and 95 | -- default Hamlet settings. 96 | -- 97 | -- For more information on modifying behavior, see: 98 | -- 99 | -- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile 100 | widgetFileSettings :: WidgetFileSettings 101 | widgetFileSettings = def 102 | 103 | -- | How static files should be combined. 104 | combineSettings :: CombineSettings 105 | combineSettings = def 106 | 107 | -- The rest of this file contains settings which rarely need changing by a 108 | -- user. 109 | 110 | widgetFile :: String -> Q Exp 111 | widgetFile = (if appReloadTemplates compileTimeAppSettings 112 | then widgetFileReload 113 | else widgetFileNoReload) 114 | widgetFileSettings 115 | 116 | -- | Raw bytes at compile time of @config/settings.yml@ 117 | configSettingsYmlBS :: ByteString 118 | configSettingsYmlBS = $(embedFile configSettingsYml) 119 | 120 | -- | @config/settings.yml@, parsed to a @Value@. 121 | configSettingsYmlValue :: Value 122 | configSettingsYmlValue = either Exception.throw id 123 | $ decodeEither' configSettingsYmlBS 124 | 125 | -- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@. 126 | compileTimeAppSettings :: AppSettings 127 | compileTimeAppSettings = 128 | case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of 129 | Error e -> error e 130 | Success settings -> settings 131 | 132 | -- The following two functions can be used to combine multiple CSS or JS files 133 | -- at compile time to decrease the number of http requests. 134 | -- Sample usage (inside a Widget): 135 | -- 136 | -- > $(combineStylesheets 'StaticR [style1_css, style2_css]) 137 | 138 | combineStylesheets :: Name -> [Route Static] -> Q Exp 139 | combineStylesheets = combineStylesheets' 140 | (appSkipCombining compileTimeAppSettings) 141 | combineSettings 142 | 143 | combineScripts :: Name -> [Route Static] -> Q Exp 144 | combineScripts = combineScripts' 145 | (appSkipCombining compileTimeAppSettings) 146 | combineSettings 147 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /stack-native.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-9.10 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.5" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor 67 | docker: 68 | enable: true 69 | 70 | image: 71 | container: 72 | base: "fpco/myapp-base" 73 | name: "gitlab.fpcomplete.com/fpco-mirors/haskell-multi-docker-example" 74 | add: 75 | static/: /opt/app/static 76 | config/: /opt/app/config 77 | 78 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-9.9 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - . 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: [] 43 | 44 | # Override default flag values for local packages and extra-deps 45 | flags: {} 46 | 47 | # Extra package databases containing global packages 48 | extra-package-dbs: [] 49 | 50 | # Control whether we use the GHC we find on the path 51 | # system-ghc: true 52 | # 53 | # Require a specific version of stack, using version ranges 54 | # require-stack-version: -any # Default 55 | # require-stack-version: ">=1.5" 56 | # 57 | # Override the architecture used by stack, especially useful on Windows 58 | # arch: i386 59 | # arch: x86_64 60 | # 61 | # Extra directories used by stack for building 62 | # extra-include-dirs: [/path/to/dir] 63 | # extra-lib-dirs: [/path/to/dir] 64 | # 65 | # Allow a newer minor version of GHC than the snapshot specifies 66 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /static/fonts/glyphicons-halflings-regular.eot: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fpco/haskell-multi-docker-example/0b3c08813a20e20ec60d3a00ecef6d15c125ad8d/static/fonts/glyphicons-halflings-regular.eot -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /static/fonts/glyphicons-halflings-regular.ttf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fpco/haskell-multi-docker-example/0b3c08813a20e20ec60d3a00ecef6d15c125ad8d/static/fonts/glyphicons-halflings-regular.ttf -------------------------------------------------------------------------------- /static/fonts/glyphicons-halflings-regular.woff: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fpco/haskell-multi-docker-example/0b3c08813a20e20ec60d3a00ecef6d15c125ad8d/static/fonts/glyphicons-halflings-regular.woff -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /templates/homepage.hamlet: -------------------------------------------------------------------------------- 1 | <div .masthead> 2 | <div .container> 3 | <div .row> 4 | <h1 .header> 5 | Yesod—a modern framework for blazing fast websites 6 | <h2> 7 | Fast, stable & spiced with great community 8 | <a href="http://www.yesodweb.com/book/" .btn.btn-info.btn-lg> 9 | Read the Book 10 | 11 | <div .container> 12 | <!-- Starting 13 | ================================================== --> 14 | <div .bs-docs-section> 15 | <div .row> 16 | <div .col-lg-12> 17 | <div .page-header> 18 | <h1 #start>Starting 19 | 20 | <p> 21 | Now that you have a working project you should use the 22 | <a href=http://www.yesodweb.com/book/>Yesod book</a> to learn more. 23 | <p> 24 | You can also use this scaffolded site to explore some concepts, and best practices. 25 | 26 | <ul .list-group> 27 | 28 | <li .list-group-item> 29 | This page was generated by the <tt>#{handlerName}</tt> handler in 30 | <tt>Handler/Home.hs</tt>. 31 | 32 | <li .list-group-item> 33 | The <tt>#{handlerName}</tt> handler is set to generate your 34 | site's home screen in Routes file 35 | <tt>config/routes 36 | 37 | <li .list-group-item> 38 | We can link to other handlers, like the <a href="@{ProfileR}">Profile</a>. 39 | Try it out as an anonymous user and see the access denied. 40 | Then, try to <a href="@{AuthR LoginR}">login</a> with the dummy authentication added 41 | while in development. 42 | 43 | <li .list-group-item> 44 | The HTML you are seeing now is actually composed by a number of <em>widgets</em>, # 45 | most of them are brought together by the <tt>defaultLayout</tt> function which # 46 | is defined in the <tt>Foundation.hs</tt> module, and used by <tt>#{handlerName}</tt>. # 47 | All the files for templates and wigdets are in <tt>templates</tt>. 48 | 49 | <li .list-group-item> 50 | A Widget's Html, Css and Javascript are separated in three files with the 51 | <tt>.hamlet</tt>, <tt>.lucius</tt> and <tt>.julius</tt> extensions. 52 | 53 | <li .list-group-item ##{aDomId}> 54 | If you had javascript enabled then you wouldn't be seeing this. 55 | 56 | <hr> 57 | 58 | <!-- Forms 59 | ================================================== --> 60 | <div .bs-docs-section> 61 | <div .row> 62 | <div .col-lg-12> 63 | <div .page-header> 64 | <h1 #forms>Forms 65 | 66 | <p> 67 | This is an example of a form. Read the 68 | <a href="http://www.yesodweb.com/book/forms">Forms chapter</a> # 69 | on the yesod book to learn more about them. 70 | 71 | <div .row> 72 | <div .col-lg-6> 73 | <div .bs-callout bs-callout-info well> 74 | <form .form-horizontal method=post action=@{HomeR}#forms enctype=#{formEnctype}> 75 | ^{formWidget} 76 | 77 | <button .btn.btn-primary type="submit"> 78 | Upload it! 79 | 80 | 81 | <div .col-lg-4.col-lg-offset-1> 82 | <div .bs-callout.bs-callout-info.upload-response> 83 | 84 | $maybe (FileForm info con) <- submission 85 | Your file type is <em>#{fileContentType info}</em>. You say it has: <em>#{con}</em> 86 | 87 | $nothing 88 | File upload result will be here... 89 | 90 | 91 | <hr> 92 | 93 | <!-- JSON 94 | ================================================== --> 95 | <div .bs-docs-section> 96 | <div .row> 97 | <div .col-lg-12> 98 | <div .page-header> 99 | <h1 #json>JSON 100 | 101 | <p> 102 | Yesod has JSON support baked-in. 103 | The form below makes an AJAX request with Javascript, 104 | then updates the page with your submission. 105 | (see <tt>Handler/Comment.hs</tt>, <tt>templates/homepage.julius</tt>, 106 | and <tt>Handler/Home.hs</tt> for the implementation). 107 | 108 | <div .row> 109 | <div .col-lg-6> 110 | <div .bs-callout.bs-callout-info.well> 111 | <form .form-horizontal ##{commentFormId}> 112 | <div .field> 113 | <textarea rows="2" ##{commentTextareaId} placeholder="Your comment here..." required></textarea> 114 | 115 | <button .btn.btn-primary type=submit> 116 | Create comment 117 | 118 | <div .col-lg-4.col-lg-offset-1> 119 | <div .bs-callout.bs-callout-info> 120 | <small> 121 | Your comments will appear here. You can also open the 122 | console log to see the raw response from the server. 123 | <ul ##{commentListId}> 124 | 125 | <hr> 126 | 127 | <!-- Testing 128 | ================================================== --> 129 | <div .bs-docs-section> 130 | <div .row> 131 | <div .col-lg-12> 132 | <div .page-header> 133 | <h1 #test>Testing 134 | 135 | <p> 136 | And last but not least, Testing. In <tt>test/Spec.hs</tt> you will find a # 137 | test suite that performs tests on this page. 138 | <p> 139 | You can run your tests by doing: <code>stack test</code> 140 | -------------------------------------------------------------------------------- /templates/homepage.julius: -------------------------------------------------------------------------------- 1 | document.getElementById(#{toJSON aDomId}).innerHTML = "This text was added by the Javascript part of the homepage widget."; 2 | 3 | $(function() { 4 | $("##{rawJS commentFormId}").submit(function(event) { 5 | event.preventDefault(); 6 | 7 | var message = $("##{rawJS commentTextareaId}").val(); 8 | // (Browsers that enforce the "required" attribute on the textarea won't see this alert) 9 | if (!message) { 10 | alert("Please fill out the comment form first."); 11 | return; 12 | } 13 | 14 | // Make an AJAX request to the server to create a new comment 15 | $.ajax({ 16 | url: '@{CommentR}', 17 | type: 'POST', 18 | contentType: "application/json", 19 | data: JSON.stringify({ 20 | message: message, 21 | }), 22 | success: function (data) { 23 | var newNode = $("<li></li>"); 24 | newNode.text(data.message); 25 | console.log(data); 26 | $("##{rawJS commentListId}").append(newNode); 27 | }, 28 | error: function (data) { 29 | console.log("Error creating comment: " + data); 30 | }, 31 | }); 32 | 33 | }); 34 | }); 35 | -------------------------------------------------------------------------------- /templates/homepage.lucius: -------------------------------------------------------------------------------- 1 | h2##{aDomId} { 2 | color: #990 3 | } 4 | 5 | li { 6 | line-height: 2em; 7 | font-size: 16px 8 | } 9 | 10 | ##{commentTextareaId} { 11 | width: 400px; 12 | height: 100px; 13 | } 14 | -------------------------------------------------------------------------------- /templates/profile.hamlet: -------------------------------------------------------------------------------- 1 | <div .ui.container> 2 | 3 | <h1> 4 | Access granted! 5 | 6 | <p> 7 | This page is protected and access is allowed only for authenticated users. 8 | 9 | <p> 10 | Your data is protected with us <strong><span class="username">#{userIdent user}</span></strong>! 11 | -------------------------------------------------------------------------------- /test/Handler/CommentSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Handler.CommentSpec (spec) where 4 | 5 | import TestImport 6 | import Data.Aeson 7 | 8 | spec :: Spec 9 | spec = withApp $ do 10 | describe "valid request" $ do 11 | it "gives a 200" $ do 12 | get HomeR 13 | statusIs 200 14 | 15 | let message = "My message" :: Text 16 | body = object [ "message" .= message ] 17 | encoded = encode body 18 | 19 | request $ do 20 | setMethod "POST" 21 | setUrl CommentR 22 | setRequestBody encoded 23 | addRequestHeader ("Content-Type", "application/json") 24 | 25 | statusIs 200 26 | 27 | [Entity _id comment] <- runDB $ selectList [CommentMessage ==. message] [] 28 | assertEq "Should have " comment (Comment message Nothing) 29 | 30 | describe "invalid requests" $ do 31 | it "400s when the JSON body is invalid" $ do 32 | get HomeR 33 | 34 | let body = object [ "foo" .= ("My message" :: Value) ] 35 | 36 | request $ do 37 | setMethod "POST" 38 | setUrl CommentR 39 | setRequestBody $ encode body 40 | addRequestHeader ("Content-Type", "application/json") 41 | 42 | statusIs 400 43 | 44 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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" "a modern framework for blazing fast websites" 15 | 16 | request $ do 17 | setMethod "POST" 18 | setUrl HomeR 19 | addToken 20 | fileByLabel "Choose a file" "test/Spec.hs" "text/plain" -- talk about self-reference 21 | byLabel "What's on the file?" "Some Content" 22 | 23 | statusIs 200 24 | -- more debugging printBody 25 | htmlAllContain ".upload-response" "text/plain" 26 | htmlAllContain ".upload-response" "Some Content" 27 | 28 | -- This is a simple example of using a database access in a test. The 29 | -- test will succeed for a fresh scaffolded site with an empty database, 30 | -- but will fail on an existing database with a non-empty user table. 31 | it "leaves the user table empty" $ do 32 | get HomeR 33 | statusIs 200 34 | users <- runDB $ selectList ([] :: [Filter User]) [] 35 | assertEq "user table empty" 0 $ length users 36 | -------------------------------------------------------------------------------- /test/Handler/ProfileSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Handler.ProfileSpec (spec) where 4 | 5 | import TestImport 6 | 7 | spec :: Spec 8 | spec = withApp $ do 9 | 10 | describe "Profile page" $ do 11 | it "asserts no access to my-account for anonymous users" $ do 12 | get ProfileR 13 | statusIs 403 14 | 15 | it "asserts access to my-account for authenticated users" $ do 16 | userEntity <- createUser "foo" 17 | authenticateAs userEntity 18 | 19 | get ProfileR 20 | statusIs 200 21 | 22 | it "asserts user's information is shown" $ do 23 | userEntity <- createUser "bar" 24 | authenticateAs userEntity 25 | 26 | get ProfileR 27 | let (Entity _ user) = userEntity 28 | htmlAnyContain ".username" . unpack $ userIdent user 29 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /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, SqlBackend, runSqlPersistMPool, rawExecute, rawSql, unSingle, connEscapeName) 13 | import Foundation as X 14 | import Model as X 15 | import Test.Hspec as X 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 | -- Wiping the database 22 | import Database.Persist.Sqlite (sqlDatabase, mkSqliteConnectionInfo, fkEnabled, createSqlitePoolFromInfo) 23 | import Control.Monad.Logger (runLoggingT) 24 | import Lens.Micro (set) 25 | import Settings (appDatabaseConf) 26 | import Yesod.Core (messageLoggerSource) 27 | 28 | runDB :: SqlPersistM a -> YesodExample App a 29 | runDB query = do 30 | pool <- fmap appConnPool getTestYesod 31 | liftIO $ runSqlPersistMPool query pool 32 | 33 | runHandler :: Handler a -> YesodExample App a 34 | runHandler handler = do 35 | app <- getTestYesod 36 | fakeHandlerGetLogger appLogger app handler 37 | 38 | withApp :: SpecWith (TestApp App) -> Spec 39 | withApp = before $ do 40 | settings <- loadYamlSettings 41 | ["config/test-settings.yml", "config/settings.yml"] 42 | [] 43 | useEnv 44 | foundation <- makeFoundation settings 45 | wipeDB foundation 46 | logWare <- liftIO $ makeLogWare foundation 47 | return (foundation, logWare) 48 | 49 | -- This function will truncate all of the tables in your database. 50 | -- 'withApp' calls it before each test, creating a clean environment for each 51 | -- spec to run in. 52 | wipeDB :: App -> IO () 53 | wipeDB app = do 54 | -- In order to wipe the database, we need to use a connection which has 55 | -- foreign key checks disabled. Foreign key checks are enabled or disabled 56 | -- per connection, so this won't effect queries outside this function. 57 | -- 58 | -- Aside: foreign key checks are enabled by persistent-sqlite, as of 59 | -- version 2.6.2, unless they are explicitly disabled in the 60 | -- SqliteConnectionInfo. 61 | 62 | let logFunc = messageLoggerSource app (appLogger app) 63 | 64 | let dbName = sqlDatabase $ appDatabaseConf $ appSettings app 65 | connInfo = set fkEnabled False $ mkSqliteConnectionInfo dbName 66 | 67 | pool <- runLoggingT (createSqlitePoolFromInfo connInfo 1) logFunc 68 | 69 | flip runSqlPersistMPool pool $ do 70 | tables <- getTables 71 | sqlBackend <- ask 72 | let queries = map (\t -> "DELETE FROM " ++ (connEscapeName sqlBackend $ DBName t)) tables 73 | forM_ queries (\q -> rawExecute q []) 74 | 75 | getTables :: MonadIO m => ReaderT SqlBackend m [Text] 76 | getTables = do 77 | tables <- rawSql "SELECT name FROM sqlite_master WHERE type = 'table';" [] 78 | return (fmap unSingle tables) 79 | 80 | -- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag 81 | -- being set in test-settings.yaml, which enables dummy authentication in 82 | -- Foundation.hs 83 | authenticateAs :: Entity User -> YesodExample App () 84 | authenticateAs (Entity _ u) = do 85 | request $ do 86 | setMethod "POST" 87 | addPostParam "ident" $ userIdent u 88 | setUrl $ AuthR $ PluginR "dummy" [] 89 | 90 | -- | Create a user. The dummy email entry helps to confirm that foreign-key 91 | -- checking is switched off in wipeDB for those database backends which need it. 92 | createUser :: Text -> YesodExample App (Entity User) 93 | createUser ident = runDB $ do 94 | user <- insertEntity User 95 | { userIdent = ident 96 | , userPassword = Nothing 97 | } 98 | _ <- insert Email 99 | { emailEmail = ident 100 | , emailUserId = Just $ entityKey user 101 | , emailVerkey = Nothing 102 | } 103 | return user 104 | --------------------------------------------------------------------------------