-
Notifications
You must be signed in to change notification settings - Fork 6
/
mysql.hsfiles
10791 lines (10460 loc) · 392 KB
/
mysql.hsfiles
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
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-# START_FILE .dir-locals.el #-}
((haskell-mode . ((haskell-indent-spaces . 4)
(haskell-process-use-ghci . t)))
(hamlet-mode . ((hamlet/basic-offset . 4)
(haskell-process-use-ghci . t))))
{-# START_FILE .gitignore #-}
dist*
static/tmp/
static/combined/
config/client_session_key.aes
*.hi
*.o
*.sqlite3
*.sqlite3-shm
*.sqlite3-wal
.hsenv*
cabal-dev/
.stack-work/
.stack-work-devel/
yesod-devel/
.cabal-sandbox
cabal.sandbox.config
.DS_Store
*.swp
*.keter
*~
\#*
{{name}}.cabal
{-# START_FILE README.md #-}
## Database Setup
After installing MySQL, run:
```
mysql --user=root
```
Then enter:
```
CREATE DATABASE {{name}};
CREATE DATABASE {{name}}_test;
CREATE USER '{{name}}'@'localhost' IDENTIFIED BY '{{name}}';
GRANT ALL PRIVILEGES ON *.* to '{{name}}'@'localhost';
```
## Haskell Setup
1. If you haven't already, [install Stack](https://haskell-lang.org/get-started)
* On POSIX systems, this is usually `curl -sSL https://get.haskellstack.org/ | sh`
2. Install the `yesod` command line tool: `stack install yesod-bin --install-ghc`
3. Build libraries: `stack build`
If you have trouble, refer to the [Yesod Quickstart guide](https://www.yesodweb.com/page/quickstart) for additional detail.
## Development
Start a development server with:
```
stack exec -- yesod devel
```
As your code changes, your site will be automatically recompiled and redeployed to localhost.
## Tests
```
stack test --flag {{name}}:library-only --flag {{name}}:dev
```
(Because `yesod devel` passes the `library-only` and `dev` flags, matching those flags means you don't need to recompile between tests and development, and it disables optimization to speed up your test compile times).
## Documentation
* Read the [Yesod Book](https://www.yesodweb.com/book) online for free
* Check [Stackage](http://stackage.org/) for documentation on the packages in your LTS Haskell version, or [search it using Hoogle](https://www.stackage.org/lts/hoogle?q=). Tip: Your LTS version is in your `stack.yaml` file.
* For local documentation, use:
* `stack haddock --open` to generate Haddock documentation for your dependencies, and open that documentation in a browser
* `stack hoogle <function, module or type signature>` to generate a Hoogle database and search for your query
* The [Yesod cookbook](https://github.com/yesodweb/yesod-cookbook) has sample code for various needs
## Getting Help
* Ask questions on [Stack Overflow, using the Yesod or Haskell tags](https://stackoverflow.com/questions/tagged/yesod+haskell)
* Ask the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb)
* There are several chatrooms you can ask for help:
* For IRC, try Freenode#yesod and Freenode#haskell
* [Functional Programming Slack](https://fpchat-invite.herokuapp.com/), in the #haskell, #haskell-beginners, or #yesod channels.
{-# START_FILE app/DevelMain.hs #-}
-- | Running your app inside GHCi.
--
-- This option provides significantly faster code reload compared to
-- @yesod devel@. However, you do not get automatic code reload
-- (which may be a benefit, depending on your perspective). To use this:
--
-- 1. Start up GHCi
--
-- $ stack ghci {{name}}:lib --no-load --work-dir .stack-work-devel
--
-- 2. Load this module
--
-- > :l app/DevelMain.hs
--
-- 3. Run @update@
--
-- > DevelMain.update
--
-- 4. Your app should now be running, you can connect at http://localhost:3000
--
-- 5. Make changes to your code
--
-- 6. After saving your changes, reload by running:
--
-- > :r
-- > DevelMain.update
--
-- You can also call @DevelMain.shutdown@ to stop the app
--
-- There is more information about this approach,
-- on the wiki: https://github.com/yesodweb/yesod/wiki/ghci
--
-- WARNING: GHCi does not notice changes made to your template files.
-- If you change a template, you'll need to either exit GHCi and reload,
-- or manually @touch@ another Haskell module.
module DevelMain where
import Prelude
import Application (getApplicationRepl, shutdownApp)
import Control.Monad ((>=>))
import Control.Concurrent
import Data.IORef
import Foreign.Store
import Network.Wai.Handler.Warp
import GHC.Word
-- | Start or restart the server.
-- newStore is from foreign-store.
-- A Store holds onto some data across ghci reloads
update :: IO ()
update = do
mtidStore <- lookupStore tidStoreNum
case mtidStore of
-- no server running
Nothing -> do
done <- storeAction doneStore newEmptyMVar
tid <- start done
_ <- storeAction (Store tidStoreNum) (newIORef tid)
return ()
-- server is already running
Just tidStore -> restartAppInNewThread tidStore
where
doneStore :: Store (MVar ())
doneStore = Store 0
-- shut the server down with killThread and wait for the done signal
restartAppInNewThread :: Store (IORef ThreadId) -> IO ()
restartAppInNewThread tidStore = modifyStoredIORef tidStore $ \tid -> do
killThread tid
withStore doneStore takeMVar
readStore doneStore >>= start
-- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId
start done = do
(port, site, app) <- getApplicationRepl
forkFinally
(runSettings (setPort port defaultSettings) app)
-- Note that this implies concurrency
-- between shutdownApp and the next app that is starting.
-- Normally this should be fine
(\_ -> putMVar done () >> shutdownApp site)
-- | kill the server
shutdown :: IO ()
shutdown = do
mtidStore <- lookupStore tidStoreNum
case mtidStore of
-- no server running
Nothing -> putStrLn "no Yesod app running"
Just tidStore -> do
withStore tidStore $ readIORef >=> killThread
putStrLn "Yesod app is shutdown"
tidStoreNum :: Word32
tidStoreNum = 1
modifyStoredIORef :: Store (IORef a) -> (a -> IO a) -> IO ()
modifyStoredIORef store f = withStore store $ \ref -> do
v <- readIORef ref
f v >>= writeIORef ref
{-# START_FILE app/devel.hs #-}
{-# LANGUAGE PackageImports #-}
import "{{name}}" Application (develMain)
import Prelude (IO)
main :: IO ()
main = develMain
{-# START_FILE app/main.hs #-}
import Prelude (IO)
import Application (appMain)
main :: IO ()
main = appMain
{-# START_FILE BASE64 config/favicon.ico #-}
AAABAAIAEBAAAAEAIABoBAAAJgAAABAQAgABAAEAsAAAAI4EAAAoAAAAEAAAACAAAAABACAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAApl4sAAAAAAAAAAAAAAAAAUEpGyNpSjaIg2NO2ZBvWfqTc13/
jW1X9YNhTMZrSTNkUTMfDwAAAAAAAAAAAAAAAAAAAAAAAAAANR0NClk6JmF+W0Txj2xV/41qVP+M
aVP/jGlS/4xpUv+MaVL/i2dQ/3pVPdNeOiEzQRsBAgAAAAAAAAAAMBgHAlIxG1h5UDb/h15D9n5W
PPZ4TzXmeVE303hQNtV4UDbVeFA11XdQNdV5UTfbbUUpx1UsEBgAAAAAAAAFADIVAwlULxY/f1M1
4dOffryecFHMXTIVhAAAAAURAAAOEwAADxQAAA8TAAAPEAAADigEABFNJAkZTSQJCRAHAQdKIARt
OxUAC1kvE3qQYEDfzJt5wXtOL9pQJAa0UScKjVInCo1SJwqNUSYJjVElCY1RJQmLUSUHslEjBGcu
EgAuVSQC/00eAGAYAAAPXzAQuLGAXs6ygV/PYTESwkMXAFRGHgI3Rx4BPEceATxHHQE7RBsBMkwf
AqlUIQHgQhoAaVUhAP9TIQDhSBwAI0EXAD5xQSHbzJp4wJRiQtBRIgKuRxsAb0kdAGpJHQBqSR0A
e04fAJNJHQClVCEA/0YcAIRVIgD/VSIA7E0fADQyDQAyaToa1MqXdMLJl3bBc0Ii6UscAJFFGgBE
RRoAQUIZAFlRIADpVSIA/1UiAP9JHwN9WicG/1QhAIMAAAAMVywPoaBtTNi6imnEsIBfya9+Xc1m
OBm2UycIilgqDYVVKQ2DVigJ4FwqCf5cKgr/Qx8GUGAwEc08EwAPTSgQY4dXN+LPnXy9g1c54XtM
LevJl3a/k2RE3WY5Gv9mNxn/Zjga/2c5G/9oOhz/Zzka/DQYBRFZLRA1JhAAJHhML9XJlnTCqXxe
zXFHLPtxRyv/n3BR2MuZd7uFWjzmc0gt/nRKLv90Sy//dUww/21CJcIAAAAATCsURXRONdR+Vjr5
j2ZL5oJbQfN+Vz3/flg//4NcQfePZkrogVk/8n5YP/6BW0H/gVtD/oBaQf9qQCRIJAgAAFAxHRt4
VDzVjWpS/4lmT/6LZ1D/jGlS/4xpU/6MaVL/i2hS/otpUv6Na1T+jmtV/o9tV/98Vj2cYzoeBgAA
AAAGAgAAZ0cyMIVkTtqae2f/mXpm/5l5Zf6Zemb+mXpm/5p6Zv+ae2f+mnxp/5p7Z/+HZE2qdE84
FAAAAAAAAAAAAAAAAAAAAABrTDgfhWVQnp2Abf+njHv/pot6/6aMev+njHv/qI18/5t+avOHZU9y
fFc/DgAAAAAAAAAAJhABAAAAAAAAAAAAyqmXADYdCQNoSDQjh2hUbpd6aJ+Zfmurl3pnlYZkTlpw
TDYTX0IxAbNeMwAAAAAAsoFfAPgfAADwBwAA4AMAAOH/AADwAQAAsPwAAJh4AAAYOAAAkAAAALAA
AADgAAAAwAEAAMABAADgAwAA8A8AAP4/AAAoAAAAEAAAACAAAAABAAEAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAA////AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA
AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA==
{-# START_FILE config/keter.yml #-}
# After you've edited this file, remove the following line to allow
# `yesod keter` to build your bundle.
#
# Also, please make sure that `port` value on `config/settings.yaml` is set to
# use `PORT` env variable.
user-edited: false
# A Keter app is composed of 1 or more stanzas. The main stanza will define our
# web application. See the Keter documentation for more information on
# available stanzas.
stanzas:
# Your Yesod application.
- type: webapp
# Name of your executable. You are unlikely to need to change this.
# Note that all file paths are relative to the keter.yml file.
#
# The path given is for Stack projects. If you're still using cabal, change
# to
# exec: ../dist/build/{{name}}/{{name}}
exec: ../dist/bin/{{name}}
# Command line options passed to your application.
args: []
hosts:
# You can specify one or more hostnames for your application to respond
# to. The primary hostname will be used for generating your application
# root.
- www.{{name}}.com
# Enable to force Keter to redirect to https
# Can be added to any stanza
requires-secure: false
# Static files.
- type: static-files
hosts:
- static.{{name}}.com
root: ../static
# Uncomment to turn on directory listings.
# directory-listing: true
# Redirect plain domain name to www.
- type: redirect
hosts:
- {{name}}.com
actions:
- host: www.{{name}}.com
# secure: false
# port: 80
# Uncomment to switch to a non-permanent redirect.
# status: 303
# Use the following to automatically copy your bundle upon creation via `yesod
# keter`. Uses `scp` internally, so you can set it to a remote destination
# copy-to: user@host:/opt/keter/incoming/
# You can pass arguments to `scp` used above. This example limits bandwidth to
# 1024 Kbit/s and uses port 2222 instead of the default 22
# copy-to-args:
# - "-l 1024"
# - "-P 2222"
# If you would like to have Keter automatically create a PostgreSQL database
# and set appropriate environment variables for it to be discovered, uncomment
# the following line.
# plugins:
# postgres: true
{-# START_FILE config/models.persistentmodels #-}
-- By default this file is used by `persistFileWith` in Model.hs (which is imported by Foundation.hs)
-- Syntax for this file here: https://github.com/yesodweb/persistent/blob/master/docs/Persistent-entity-syntax.md
User
ident Text sqltype=varchar(255)
password Text Maybe sqltype=varchar(255) default=NULL
UniqueUser ident
deriving Typeable
Email
email Text sqltype=varchar(255)
userId UserId Maybe sqltype=varchar(255) default=NULL
verkey Text Maybe sqltype=varchar(255) default=NULL
UniqueEmail email
Comment json -- Adding "json" causes ToJSON and FromJSON instances to be derived.
message Text sqltype=varchar(255)
userId UserId Maybe sqltype=varchar(255) default=NULL
deriving Eq
deriving Show
{-# START_FILE config/robots.txt #-}
User-agent: *
{-# START_FILE config/routes.yesodroutes #-}
-- By default this file is used by `parseRoutesFile` in Foundation.hs
-- Syntax for this file here: https://www.yesodweb.com/book/routing-and-handlers
/static StaticR Static appStatic
/auth AuthR Auth getAuth
/favicon.ico FaviconR GET
/robots.txt RobotsR GET
/ HomeR GET POST
/comments CommentR POST
/profile ProfileR GET
{-# START_FILE config/settings.yml #-}
# Values formatted like "_env:YESOD_ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
# See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables
static-dir: "_env:YESOD_STATIC_DIR:static"
host: "_env:YESOD_HOST:*4" # any IPv4 host
port: "_env:YESOD_PORT:3000" # NB: The port `yesod devel` uses is distinct from this value. Set the `yesod devel` port from the command line.
# For `keter` user, enable the follwing line, and comment out previous one.
#port: "_env:PORT:3000" # `keter` uses `PORT` env var name
ip-from-header: "_env:YESOD_IP_FROM_HEADER:false"
# Default behavior: determine the application root from the request headers.
# Uncomment to set an explicit approot
#approot: "_env:YESOD_APPROOT:http://localhost:3000"
# By default, `yesod devel` runs in development, and built executables use
# production settings (see below). To override this, use the following:
#
# development: false
# Optional values with the following production defaults.
# In development, they default to the inverse.
#
# detailed-logging: false
# should-log-all: false
# reload-templates: false
# mutable-static: false
# skip-combining: false
# auth-dummy-login : false
# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:YESOD_PGPASS:'123'")
# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings
database:
user: "_env:YESOD_MYSQL_USER:{{name}}"
password: "_env:YESOD_MYSQL_PASSWORD:{{name}}"
host: "_env:YESOD_MYSQL_HOST:localhost"
port: "_env:YESOD_MYSQL_PORT:5432"
# See config/test-settings.yml for an override during tests
database: "_env:YESOD_MYSQL_DATABASE:{{name}}"
poolsize: "_env:YESOD_MYSQL_POOLSIZE:10"
copyright: Insert copyright statement here
#analytics: UA-YOURCODE
{-# START_FILE config/test-settings.yml #-}
database:
# NOTE: By design, this setting prevents the MYSQL_DATABASE environment variable
# from affecting test runs, so that we don't accidentally affect the
# production database during testing. If you're not concerned about that and
# would like to have environment variable overrides, you could instead use
# something like:
#
# database: "_env:MYSQL_DATABASE:{{name}}_test"
database: {{name}}_test
auth-dummy-login: true
{-# START_FILE package.yaml #-}
name: {{name}}
version: "0.0.0"
dependencies:
- base >=4.9.1.0 && <5
- yesod >=1.6 && <1.7
- yesod-core >=1.6 && <1.7
- yesod-auth >=1.6 && <1.7
- yesod-static >=1.6 && <1.7
- yesod-form >=1.6 && <1.8
- classy-prelude >=1.5 && <1.6
- classy-prelude-conduit >=1.5 && <1.6
- classy-prelude-yesod >=1.5 && <1.6
- bytestring >=0.10 && <0.12
- text >=0.11 && <2.0
- persistent >=2.9 && <2.14
- persistent-mysql >=2.9 && <2.14
- mysql >= 0.1.4
- persistent-template >=2.5 && <2.14
- template-haskell
- shakespeare >=2.0 && <2.1
- hjsmin >=0.1 && <0.3
- monad-control >=0.3 && <1.1
- wai-extra >=3.0 && <3.2
- yaml >=0.11 && <0.12
- http-client-tls >=0.3 && <0.4
- http-conduit >=2.3 && <2.4
- directory >=1.1 && <1.4
- warp >=3.0 && <3.4
- data-default
- aeson >=1.4 && <2.1
- conduit >=1.0 && <2.0
- monad-logger >=0.3 && <0.4
- fast-logger >=2.2 && <3.2
- wai-logger >=2.2 && <2.5
- file-embed
- safe
- unordered-containers
- containers
- vector
- time
- case-insensitive
- wai
- foreign-store
# The library contains all of our application code. The executable
# defined below is just a thin wrapper.
library:
source-dirs: src
when:
- condition: (flag(dev)) || (flag(library-only))
then:
ghc-options:
- -Wall
- -fwarn-tabs
- -O0
cpp-options: -DDEVELOPMENT
else:
ghc-options:
- -Wall
- -fwarn-tabs
- -O2
# Runnable executable for our application
executables:
{{name}}:
main: main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- {{name}}
when:
- condition: flag(library-only)
buildable: false
# Test suite
tests:
{{name}}-test:
main: Spec.hs
source-dirs: test
ghc-options: -Wall
dependencies:
- {{name}}
- hspec >=2.0.0
- yesod-test
# Define flags used by "yesod devel" to make compilation faster
flags:
library-only:
description: Build for use with "yesod devel"
manual: false
default: false
dev:
description: Turn on development settings, like auto-reload templates.
manual: false
default: false
{-# START_FILE src/Application.hs #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( getApplicationDev
, appMain
, develMain
, makeFoundation
, makeLogWare
-- * for DevelMain
, getApplicationRepl
, shutdownApp
-- * for GHCI
, handler
, db
) where
#if MIN_VERSION_base(4,9,0)
import Control.Concurrent (forkOSWithUnmask)
#else
import GHC.IO (unsafeUnmask)
#endif
import Control.Monad.Logger (liftLoc, runLoggingT)
import Database.Persist.MySQL (createMySQLPool, myConnInfo,
myPoolSize, runSqlPool)
import qualified Database.MySQL.Base as MySQL
import Import
import Language.Haskell.TH.Syntax (qLocation)
import Network.HTTP.Client.TLS (getGlobalManager)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp (Settings, defaultSettings,
defaultShouldDisplayException,
runSettings, setHost,
setFork, setOnOpen, setOnClose,
setOnException, setPort, getPort)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
IPAddrSource (..),
OutputFormat (..), destination,
mkRequestLogger, outputFormat)
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
toLogStr)
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Common
import Handler.Home
import Handler.Comment
import Handler.Profile
-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
-- comments there for more details.
mkYesodDispatch "App" resourcesApp
-- | This function allocates resources (such as a database connection pool),
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO App
makeFoundation appSettings = do
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
appHttpManager <- getGlobalManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <-
(if appMutableStatic appSettings then staticDevel else static)
(appStaticDir appSettings)
-- See http://www.yesodweb.com/blog/2016/11/use-mysql-safely-in-yesod
MySQL.initLibrary
-- We need a log function to create a connection pool. We need a connection
-- pool to create our foundation. And we need our foundation to get a
-- logging function. To get out of this loop, we initially create a
-- temporary foundation without a real connection pool, get a log function
-- from there, and then create the real foundation.
let mkFoundation appConnPool = App {..}
-- The App {..} syntax is an example of record wild cards. For more
-- information, see:
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
logFunc = messageLoggerSource tempFoundation appLogger
-- Create the database connection pool
pool <- flip runLoggingT logFunc $ createMySQLPool
(myConnInfo $ appDatabaseConf appSettings)
(myPoolSize $ appDatabaseConf appSettings)
-- Perform database migration using our application's logging settings.
runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
-- Return the foundation
return $ mkFoundation pool
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: App -> IO Application
makeApplication foundation = do
logWare <- makeLogWare foundation
-- Create the WAI application and apply middlewares
appPlain <- toWaiAppPlain foundation
return $ logWare $ defaultMiddlewaresNoLogging appPlain
makeLogWare :: App -> IO Middleware
makeLogWare foundation =
mkRequestLogger def
{ outputFormat =
if appDetailedRequestLogging $ appSettings foundation
then Detailed True
else Apache
(if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket)
, destination = Logger $ loggerSet $ appLogger foundation
}
#if ! MIN_VERSION_base(4,9,0)
forkOSWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
forkOSWithUnmask io = forkOS (io unsafeUnmask)
#endif
-- | Warp settings for the given foundation value.
-- Use bound threads for thread-safe use of MySQL, and initialise and finalise
-- them: see http://www.yesodweb.com/blog/2016/11/use-mysql-safely-in-yesod
warpSettings :: App -> Settings
warpSettings foundation =
setPort (appPort $ appSettings foundation)
$ setHost (appHost $ appSettings foundation)
$ setOnException (\_req e ->
when (defaultShouldDisplayException e) $ messageLoggerSource
foundation
(appLogger foundation)
$(qLocation >>= liftLoc)
"yesod"
LevelError
(toLogStr $ "Exception from Warp: " ++ show e))
$ setFork (\x -> void $ forkOSWithUnmask x)
$ setOnOpen (const $ MySQL.initThread >> return True)
$ setOnClose (const MySQL.endThread)
defaultSettings
-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: IO (Settings, Application)
getApplicationDev = do
settings <- getAppSettings
foundation <- makeFoundation settings
wsettings <- getDevSettings $ warpSettings foundation
app <- makeApplication foundation
return (wsettings, app)
getAppSettings :: IO AppSettings
getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv
-- | main function for use by yesod devel
develMain :: IO ()
develMain = develMainHelper getApplicationDev
-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain = do
-- Get the settings from all relevant sources
settings <- loadYamlSettingsArgs
-- fall back to compile-time values, set to [] to require values at runtime
[configSettingsYmlValue]
-- allow environment variables to override
useEnv
-- Generate the foundation from the settings
foundation <- makeFoundation settings
-- Generate a WAI Application from the foundation
app <- makeApplication foundation
-- Run the application with Warp
runSettings (warpSettings foundation) app
--------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the app from GHCi)
--------------------------------------------------------------
getApplicationRepl :: IO (Int, App, Application)
getApplicationRepl = do
settings <- getAppSettings
foundation <- makeFoundation settings
wsettings <- getDevSettings $ warpSettings foundation
app1 <- makeApplication foundation
return (getPort wsettings, foundation, app1)
shutdownApp :: App -> IO ()
shutdownApp _ = return ()
---------------------------------------------
-- Functions for use in development with GHCi
---------------------------------------------
-- | Run a handler
handler :: Handler a -> IO a
handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
-- | Run DB queries
db :: ReaderT SqlBackend Handler a -> IO a
db = handler . runDB
{-# START_FILE src/Foundation.hs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE InstanceSigs #-}
module Foundation where
import Import.NoFoundation
import Data.Kind (Type)
import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym)
import Control.Monad.Logger (LogSource)
-- Used only when in "auth-dummy-login" setting is enabled.
import Yesod.Auth.Dummy
import Yesod.Auth.OpenId (authOpenId, IdentifierType (Claimed))
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Core.Types (Logger)
import qualified Yesod.Core.Unsafe as Unsafe
import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding as TE
-- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
-- access to the data present here.
data App = App
{ appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving.
, appConnPool :: ConnectionPool -- ^ Database connection pool.
, appHttpManager :: Manager
, appLogger :: Logger
}
data MenuItem = MenuItem
{ menuItemLabel :: Text
, menuItemRoute :: Route App
, menuItemAccessCallback :: Bool
}
data MenuTypes
= NavbarLeft MenuItem
| NavbarRight MenuItem
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers
--
-- Note that this is really half the story; in Application.hs, mkYesodDispatch
-- generates the rest of the code. Please see the following documentation
-- for an explanation for this split:
-- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
--
-- This function also generates the following type synonyms:
-- type Handler = HandlerFor App
-- type Widget = WidgetFor App ()
mkYesodData "App" $(parseRoutesFile "config/routes.yesodroutes")
-- | A convenient synonym for creating forms.
type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget)
-- | A convenient synonym for database access functions.
type DB a = forall (m :: Type -> Type).
(MonadUnliftIO m) => ReaderT SqlBackend m a
-- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here.
instance Yesod App where
-- Controls the base of generated URLs. For more information on modifying,
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
approot :: Approot App
approot = ApprootRequest $ \app req ->
case appRoot $ appSettings app of
Nothing -> getApprootText guessApproot app req
Just root -> root
-- Store session data on the client in encrypted cookies,
-- default session idle timeout is 120 minutes
makeSessionBackend :: App -> IO (Maybe SessionBackend)
makeSessionBackend _ = Just <$> defaultClientSessionBackend
120 -- timeout in minutes
"config/client_session_key.aes"
-- Yesod Middleware allows you to run code before and after each handler function.
-- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks.
-- Some users may also want to add the defaultCsrfMiddleware, which:
-- a) Sets a cookie with a CSRF token in it.
-- b) Validates that incoming write requests include that token in either a header or POST parameter.
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
yesodMiddleware :: ToTypedContent res => Handler res -> Handler res
yesodMiddleware = defaultYesodMiddleware
defaultLayout :: Widget -> Handler Html
defaultLayout widget = do
master <- getYesod
mmsg <- getMessage
muser <- maybeAuthPair
mcurrentRoute <- getCurrentRoute
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
(title, parents) <- breadcrumbs
-- Define the menu items of the header.
let menuItems =
[ NavbarLeft $ MenuItem
{ menuItemLabel = "Home"
, menuItemRoute = HomeR
, menuItemAccessCallback = True
}
, NavbarLeft $ MenuItem
{ menuItemLabel = "Profile"
, menuItemRoute = ProfileR
, menuItemAccessCallback = isJust muser
}
, NavbarRight $ MenuItem
{ menuItemLabel = "Login"
, menuItemRoute = AuthR LoginR
, menuItemAccessCallback = isNothing muser
}
, NavbarRight $ MenuItem
{ menuItemLabel = "Logout"
, menuItemRoute = AuthR LogoutR
, menuItemAccessCallback = isJust muser
}
]
let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems]
let navbarRightMenuItems = [x | NavbarRight x <- menuItems]
let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x]
let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x]
-- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and
-- default-layout-wrapper is the entire page. Since the final
-- value passed to hamletToRepHtml cannot be a widget, this allows
-- you to use normal widget features in default-layout.
pc <- widgetToPageContent $ do
addStylesheet $ StaticR css_bootstrap_css
-- ^ generated from @Settings/StaticFiles.hs@
$(widgetFile "default-layout")
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-- The page to be redirected to when authentication is required.
authRoute
:: App
-> Maybe (Route App)
authRoute _ = Just $ AuthR LoginR
isAuthorized
:: Route App -- ^ The route the user is visiting.
-> Bool -- ^ Whether or not this is a "write" request.
-> Handler AuthResult
-- Routes not requiring authentication.
isAuthorized (AuthR _) _ = return Authorized
isAuthorized CommentR _ = return Authorized
isAuthorized HomeR _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
isAuthorized (StaticR _) _ = return Authorized
-- the profile route requires that the user is authenticated, so we
-- delegate to that function
isAuthorized ProfileR _ = isAuthenticated
-- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows
-- expiration dates to be set far in the future without worry of
-- users receiving stale content.
addStaticContent
:: Text -- ^ The file extension
-> Text -- ^ The MIME content type
-> LByteString -- ^ The contents of the file
-> Handler (Maybe (Either Text (Route App, [(Text, Text)])))
addStaticContent ext mime content = do
master <- getYesod
let staticDir = appStaticDir $ appSettings master
addStaticContentExternal
minifym
genFileName
staticDir
(StaticR . flip StaticRoute [])
ext
mime
content
where
-- Generate a unique filename based on the content itself
genFileName lbs = "autogen-" ++ base64md5 lbs
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool
shouldLogIO app _source level =
return $
appShouldLogAll (appSettings app)
|| level == LevelWarn
|| level == LevelError
makeLogger :: App -> IO Logger
makeLogger = return . appLogger
-- Define breadcrumbs.
instance YesodBreadcrumbs App where
-- Takes the route that the user is currently on, and returns a tuple
-- of the 'Text' that you want the label to display, and a previous
-- breadcrumb route.
breadcrumb
:: Route App -- ^ The route the user is visiting currently.
-> Handler (Text, Maybe (Route App))
breadcrumb HomeR = return ("Home", Nothing)
breadcrumb (AuthR _) = return ("Login", Just HomeR)
breadcrumb ProfileR = return ("Profile", Just HomeR)
breadcrumb _ = return ("home", Nothing)
-- How to run database actions.
instance YesodPersist App where
type YesodPersistBackend App = SqlBackend
runDB :: SqlPersistT Handler a -> Handler a
runDB action = do
master <- getYesod
runSqlPool action $ appConnPool master
instance YesodPersistRunner App where
getDBRunner :: Handler (DBRunner App, Handler ())
getDBRunner = defaultGetDBRunner appConnPool
instance YesodAuth App where
type AuthId App = UserId
-- Where to send a user after successful login
loginDest :: App -> Route App
loginDest _ = HomeR
-- Where to send a user after logout
logoutDest :: App -> Route App
logoutDest _ = HomeR
-- Override the above two destinations when a Referer: header is present
redirectToReferer :: App -> Bool
redirectToReferer _ = True
authenticate :: (MonadHandler m, HandlerSite m ~ App)
=> Creds App -> m (AuthenticationResult App)
authenticate creds = liftHandler $ runDB $ do
x <- getBy $ UniqueUser $ credsIdent creds
case x of
Just (Entity uid _) -> return $ Authenticated uid
Nothing -> Authenticated <$> insert User
{ userIdent = credsIdent creds
, userPassword = Nothing
}
-- You can add other plugins like Google Email, email or OAuth here
authPlugins :: App -> [AuthPlugin App]
authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins
-- Enable authDummy login if enabled.
where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app]
-- | Access function to determine if a user is logged in.
isAuthenticated :: Handler AuthResult
isAuthenticated = do
muid <- maybeAuthId
return $ case muid of