├── .gitignore ├── .travis.yml ├── LICENSE ├── Makefile ├── README.md ├── app ├── DevelMain.hs ├── devel.hs ├── fixtures │ └── Main.hs ├── main.hs ├── migration │ └── Main.hs └── truncate │ └── Main.hs ├── config ├── favicon.ico ├── keter.yml ├── robots.txt ├── settings.yml └── test-settings.yml ├── package.yaml ├── src ├── AppType.hs ├── Application.hs ├── Foundation.hs ├── Handler │ ├── Admin.hs │ ├── Auth.hs │ ├── Auth │ │ ├── Forms.hs │ │ └── Views.hs │ ├── Comment.hs │ ├── Comment │ │ ├── Query.hs │ │ ├── Views.hs │ │ └── comment.txt │ ├── Home.hs │ ├── Sessions.hs │ ├── Settings.hs │ └── User.hs ├── Helpers │ ├── Forms.hs │ ├── Handlers.hs │ └── Views.hs ├── Import.hs ├── Import │ └── NoFoundation.hs ├── Model.hs ├── Model │ ├── BCrypt.hs │ ├── Fixtures.hs │ └── Types.hs ├── Routes.hs ├── Settings.hs └── Settings │ └── StaticFiles.hs ├── stack.yaml ├── static ├── css │ ├── app.css │ └── bootstrap.css └── fonts │ ├── glyphicons-halflings-regular.eot │ ├── glyphicons-halflings-regular.svg │ ├── glyphicons-halflings-regular.ttf │ └── glyphicons-halflings-regular.woff └── test ├── Spec.hs └── TestImport.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist* 2 | static/tmp/ 3 | static/combined/ 4 | config/client_session_key.aes 5 | *.hi 6 | *.o 7 | *.sqlite3 8 | *.sqlite3-shm 9 | *.sqlite3-wal 10 | .hsenv* 11 | cabal-dev/ 12 | .stack-work/ 13 | yesod-devel/ 14 | .cabal-sandbox 15 | cabal.sandbox.config 16 | .DS_Store 17 | *.swp 18 | *.keter 19 | *~ 20 | \#* 21 | badgers.cabal 22 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: false 2 | language: generic 3 | 4 | install: 5 | # stack 6 | - mkdir -p ~/.local/bin 7 | - travis_retry curl -L https://github.com/commercialhaskell/stack/releases/download/v1.6.1/stack-1.6.1-linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 8 | - export PATH=~/.local/bin:$PATH 9 | - stack --no-terminal --version 10 | 11 | script: 12 | - stack setup --no-terminal 13 | - stack update --no-terminal 14 | - make build-fast 15 | 16 | cache: 17 | timeout: 2000 18 | directories: 19 | - $HOME/.cabal 20 | - $HOME/.ghc 21 | - $HOME/.stack 22 | - .stack-work/ 23 | apt: true 24 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2018 FPComplete 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | package = badgers 2 | 3 | stack_yaml = STACK_YAML="stack.yaml" 4 | stack = $(stack_yaml) stack 5 | 6 | build: 7 | $(stack) build $(package) 8 | 9 | build-fast: 10 | $(stack) build -j2 --fast --no-terminal 11 | 12 | build-dirty: 13 | $(stack) build --force-dirty $(package) 14 | 15 | build-profile: 16 | $(stack) --work-dir .stack-work-profiling --profile build 17 | 18 | run: 19 | $(stack) build --fast && $(stack) exec -- $(package) 20 | 21 | install: 22 | $(stack) install 23 | 24 | ghci: 25 | $(stack) ghci $(package):lib --ghci-options='-j4 +RTS -A128m' 26 | 27 | test: 28 | $(stack) test $(package) 29 | 30 | test-ghci: 31 | $(stack) ghci $(package):test:$(package)-tests 32 | 33 | bench: 34 | $(stack) bench $(package) 35 | 36 | ghcid: 37 | $(stack) exec -- ghcid -c "stack ghci $(package):lib --test --ghci-options='-fobject-code -fno-warn-unused-do-bind' --main-is $(package):$(package)" 38 | 39 | dev-deps: 40 | stack install ghcid 41 | 42 | psql: 43 | sudo -u postgres psql badgers_dev 44 | 45 | reset-database: destroy-create-db migration fixtures 46 | 47 | reset-data: truncate-tables fixtures 48 | 49 | create-db-user: 50 | sudo -u postgres createuser badgers --password badgers --superuser 51 | 52 | destroy-create-db: 53 | -sudo -u postgres dropdb badgers_dev 54 | sudo -u postgres createdb -O badgers badgers_dev 55 | 56 | migration: build 57 | stack exec -- migration 58 | 59 | fixtures: build 60 | stack exec -- fixtures 61 | 62 | truncate-tables: build 63 | stack exec -- truncate 64 | 65 | .PHONY : build build-dirty run install ghci test test-ghci ghcid dev-deps 66 | 67 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ## Badgers 2 | 3 | This is a clone of [lobste.rs](https://lobste.rs) that is being used as a training and practice project for some folks that I (Chris Allen) am working with. You're welcome to clone it and kick it around but I won't be taking any PRs or issues from third parties for now until the folks I am helping are done with this project. 4 | 5 | ## Database Setup 6 | 7 | After installing Postgres, run: 8 | 9 | ``` 10 | createuser --username badgers --password badgers --superuser 11 | createdb -O badgers badgers_dev 12 | createdb -O badgers badgers_test 13 | ``` 14 | 15 | If you're on Linux you might have a `postgres` system user you need to impersonate in order to perform these actions, if that's the case then the commands are: 16 | 17 | ``` 18 | createuser badgers --password badgers --superuser 19 | createdb -O badgers badgers_dev 20 | createdb -O badgers badgers_test 21 | ``` 22 | 23 | There's also Makefile targets that make this easy. 24 | 25 | ## Haskell Setup 26 | 27 | 1. If you haven't already, [install Stack](https://haskell-lang.org/get-started) 28 | * On POSIX systems, this is usually `curl -sSL https://get.haskellstack.org/ | sh` 29 | 2. Install the `yesod` command line tool: `stack install yesod-bin --install-ghc` 30 | 3. Build libraries: `stack build` 31 | 32 | If you have trouble, refer to the [Yesod Quickstart guide](https://www.yesodweb.com/page/quickstart) for additional detail. 33 | 34 | ## Development 35 | 36 | Start a development server with: 37 | 38 | ``` 39 | stack exec -- yesod devel 40 | ``` 41 | 42 | As your code changes, your site will be automatically recompiled and redeployed to localhost. 43 | 44 | ## Tests 45 | 46 | ``` 47 | stack test --flag badgers:library-only --flag badgers:dev 48 | ``` 49 | 50 | (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). 51 | 52 | ## Documentation 53 | 54 | * Read the [Yesod Book](https://www.yesodweb.com/book) online for free 55 | * 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. 56 | * For local documentation, use: 57 | _ `stack haddock --open` to generate Haddock documentation for your dependencies, and open that documentation in a browser 58 | _ `stack hoogle ` to generate a Hoogle database and search for your query 59 | * The [Yesod cookbook](https://github.com/yesodweb/yesod-cookbook) has sample code for various needs 60 | 61 | ## Getting Help 62 | 63 | * Ask questions on [Stack Overflow, using the Yesod or Haskell tags](https://stackoverflow.com/questions/tagged/yesod+haskell) 64 | * Ask the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb) 65 | * There are several chatrooms you can ask for help: 66 | _ For IRC, try Freenode#yesod and Freenode#haskell 67 | _ [Functional Programming Slack](https://fpchat-invite.herokuapp.com/), in the #haskell, #haskell-beginners, or #yesod channels. 68 | -------------------------------------------------------------------------------- /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 "badgers" Application (develMain) 3 | import Prelude (IO) 4 | 5 | main :: IO () 6 | main = develMain 7 | -------------------------------------------------------------------------------- /app/fixtures/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude (IO) 4 | import Model (runDevDB) 5 | import Model.Fixtures (wipeAndReinstallFixtures) 6 | 7 | main :: IO () 8 | main = 9 | runDevDB wipeAndReinstallFixtures 10 | -------------------------------------------------------------------------------- /app/main.hs: -------------------------------------------------------------------------------- 1 | import Prelude (IO) 2 | import Application (appMain) 3 | 4 | main :: IO () 5 | main = appMain 6 | -------------------------------------------------------------------------------- /app/migration/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude 4 | 5 | import Model 6 | 7 | main :: IO () 8 | main = do 9 | runDevDB runMigrations 10 | 11 | -------------------------------------------------------------------------------- /app/truncate/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Prelude (IO) 4 | import Model (runDevDB) 5 | import Model.Fixtures (truncateAllTables) 6 | 7 | main :: IO () 8 | main = 9 | runDevDB truncateAllTables 10 | -------------------------------------------------------------------------------- /config/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/fpco/badgers/170fa0df4bd52241db0884a09b905a919b37ab1b/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/badgers/badgers 19 | exec: ../dist/bin/badgers 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.badgers.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.badgers.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 | - badgers.com 48 | actions: 49 | - host: www.badgers.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/robots.txt: -------------------------------------------------------------------------------- 1 | User-agent: * 2 | -------------------------------------------------------------------------------- /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 | # By default, `yesod devel` runs in development, and built executables use 14 | # production settings (see below). To override this, use the following: 15 | # 16 | # development: false 17 | 18 | # Optional values with the following production defaults. 19 | # In development, they default to the inverse. 20 | # 21 | # detailed-logging: false 22 | # should-log-all: false 23 | # reload-templates: false 24 | # mutable-static: false 25 | # skip-combining: false 26 | # auth-dummy-login : false 27 | 28 | # NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'") 29 | # See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings 30 | 31 | database: 32 | user: "_env:PGUSER:badgers" 33 | password: "_env:PGPASS:badgers" 34 | host: "_env:PGHOST:localhost" 35 | port: "_env:PGPORT:5432" 36 | # See config/test-settings.yml for an override during tests 37 | database: "_env:PGDATABASE:badgers_dev" 38 | poolsize: "_env:PGPOOLSIZE:10" 39 | 40 | copyright: Insert copyright statement here 41 | #analytics: UA-YOURCODE 42 | -------------------------------------------------------------------------------- /config/test-settings.yml: -------------------------------------------------------------------------------- 1 | database: 2 | # NOTE: By design, this setting prevents the PGDATABASE environment variable 3 | # from affecting test runs, so that we don't accidentally affect the 4 | # production database during testing. If you're not concerned about that and 5 | # would like to have environment variable overrides, you could instead use 6 | # something like: 7 | # 8 | # database: "_env:PGDATABASE:badgers_test" 9 | database: badgers_test 10 | 11 | auth-dummy-login: true 12 | -------------------------------------------------------------------------------- /package.yaml: -------------------------------------------------------------------------------- 1 | name: badgers 2 | version: "0.0.1" 3 | license: MIT 4 | 5 | default-extensions: 6 | - BangPatterns 7 | - ConstraintKinds 8 | - DataKinds 9 | - DeriveDataTypeable 10 | - DeriveGeneric 11 | - EmptyDataDecls 12 | - FlexibleContexts 13 | - FlexibleInstances 14 | - GADTs 15 | - GeneralizedNewtypeDeriving 16 | - InstanceSigs 17 | - MultiParamTypeClasses 18 | - NoImplicitPrelude 19 | - NoMonomorphismRestriction 20 | - OverloadedStrings 21 | - QuasiQuotes 22 | - RankNTypes 23 | - RecordWildCards 24 | - ScopedTypeVariables 25 | - TemplateHaskell 26 | - TupleSections 27 | - TypeFamilies 28 | - TypeOperators 29 | - ViewPatterns 30 | 31 | dependencies: 32 | 33 | # Due to a bug in GHC 8.0.1, we block its usage 34 | # See: https://ghc.haskell.org/trac/ghc/ticket/12130 35 | - base >=4.8.2.0 && <4.9 || >=4.9.1.0 && <5 36 | 37 | - aeson >=0.6 && <1.3 38 | - bcrypt >= 0.0.8 && < 0.0.12 39 | - bytestring >=0.9 && <0.11 40 | - case-insensitive 41 | - classy-prelude >=1.4 && <1.5 42 | - classy-prelude-conduit >=1.4 && <1.5 43 | - classy-prelude-yesod >=1.4 && <1.5 44 | - conduit >=1.0 && <2.0 45 | - containers 46 | - data-default 47 | - directory >=1.1 && <1.4 48 | - errors 49 | - esqueleto >= 2.5 && < 2.7 50 | - fast-logger >=2.2 && <2.5 51 | - file-embed 52 | - foreign-store 53 | - hjsmin >=0.1 && <0.3 54 | - http-client-tls >=0.3 && <0.4 55 | - http-conduit >=2.3 && <2.4 56 | - monad-control >=0.3 && <1.1 57 | - monad-logger >=0.3 && <0.4 58 | - persistent >=2.8 && <2.9 59 | - persistent-postgresql >=2.8 && <2.9 60 | - persistent-template >=2.5 && <2.9 61 | - random-strings 62 | - safe 63 | - shakespeare >=2.0 && <2.1 64 | - template-haskell 65 | - text >=0.11 && <2.0 66 | - transformers 67 | - time 68 | - unordered-containers 69 | - vector 70 | - wai 71 | - wai-extra >=3.0 && <3.1 72 | - wai-logger >=2.2 && <2.4 73 | - warp >=3.0 && <3.3 74 | - yaml >=0.8 && <0.9 75 | - yesod >=1.6 && <1.7 76 | - yesod-auth >=1.6 && <1.7 77 | - yesod-core >=1.6 && <1.7 78 | - yesod-form >=1.6 && <1.7 79 | - yesod-static >=1.6 && <1.7 80 | 81 | # The library contains all of our application code. The executable 82 | # defined below is just a thin wrapper. 83 | library: 84 | source-dirs: src 85 | exposed-modules: 86 | - Application 87 | - Import 88 | - Model 89 | - Model.Fixtures 90 | when: 91 | - condition: (flag(dev)) || (flag(library-only)) 92 | then: 93 | ghc-options: 94 | - -Wall 95 | - -fwarn-tabs 96 | - -O0 97 | cpp-options: -DDEVELOPMENT 98 | else: 99 | ghc-options: 100 | - -Wall 101 | - -fwarn-tabs 102 | - -O2 103 | 104 | # Runnable executable for our application 105 | executables: 106 | badgers: 107 | main: main.hs 108 | source-dirs: app 109 | ghc-options: 110 | - -threaded 111 | - -rtsopts 112 | - -with-rtsopts=-N 113 | dependencies: 114 | - badgers 115 | when: 116 | - condition: flag(library-only) 117 | buildable: false 118 | migration: 119 | when: 120 | - condition: flag(library-only) 121 | buildable: false 122 | main: Main.hs 123 | source-dirs: 124 | - app/migration 125 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 126 | dependencies: 127 | - badgers 128 | fixtures: 129 | when: 130 | - condition: flag(library-only) 131 | buildable: false 132 | main: Main.hs 133 | source-dirs: 134 | - app/fixtures 135 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 136 | dependencies: 137 | - badgers 138 | truncate: 139 | when: 140 | - condition: flag(library-only) 141 | buildable: false 142 | main: Main.hs 143 | source-dirs: 144 | - app/truncate 145 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 146 | dependencies: 147 | - badgers 148 | 149 | # Test suite 150 | tests: 151 | badgers-test: 152 | main: Spec.hs 153 | source-dirs: test 154 | ghc-options: -Wall 155 | dependencies: 156 | - badgers 157 | - hspec >=2.0.0 158 | - yesod-test 159 | 160 | # Define flags used by "yesod devel" to make compilation faster 161 | flags: 162 | library-only: 163 | description: Build for use with "yesod devel" 164 | manual: false 165 | default: false 166 | dev: 167 | description: Turn on development settings, like auto-reload templates. 168 | manual: false 169 | default: false 170 | -------------------------------------------------------------------------------- /src/AppType.hs: -------------------------------------------------------------------------------- 1 | module AppType where 2 | 3 | import Import.NoFoundation 4 | 5 | import Database.Persist.Sql (ConnectionPool) 6 | import Yesod.Core.Types (Logger) 7 | 8 | -- | The foundation datatype for your application. This can be a good place to 9 | -- keep settings and values requiring initialization before your application 10 | -- starts running, such as database connections. Every handler will have 11 | -- access to the data present here. 12 | data App = App 13 | { appSettings :: AppSettings 14 | , appStatic :: Static -- ^ Settings for static file serving. 15 | , appConnPool :: ConnectionPool -- ^ Database connection pool. 16 | , appHttpManager :: Manager 17 | , appLogger :: Logger 18 | } 19 | -------------------------------------------------------------------------------- /src/Application.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE TypeFamilies #-} 6 | {-# LANGUAGE ViewPatterns #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | module Application 10 | ( getApplicationDev 11 | , appMain 12 | , develMain 13 | , makeFoundation 14 | , makeLogWare 15 | -- * for DevelMain 16 | , getApplicationRepl 17 | , shutdownApp 18 | -- * for GHCI 19 | , handler 20 | , db 21 | ) where 22 | 23 | import Control.Monad.Logger (liftLoc, runLoggingT) 24 | import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr, 25 | pgPoolSize) 26 | import Import 27 | import Language.Haskell.TH.Syntax (qLocation) 28 | import Network.HTTP.Client.TLS (getGlobalManager) 29 | import Network.Wai (Middleware) 30 | import Network.Wai.Handler.Warp (Settings, defaultSettings, 31 | defaultShouldDisplayException, 32 | runSettings, setHost, 33 | setOnException, setPort, getPort) 34 | import Network.Wai.Middleware.RequestLogger (Destination (Logger), 35 | IPAddrSource (..), 36 | OutputFormat (..), destination, 37 | mkRequestLogger, outputFormat) 38 | import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet, 39 | toLogStr) 40 | 41 | -- Import all relevant handler modules here. 42 | -- Don't forget to add new modules to your cabal file! 43 | import Handler.Admin 44 | import Handler.Auth 45 | import Handler.Comment 46 | import Handler.Home 47 | import Handler.Settings 48 | import Handler.User 49 | 50 | -- This line actually creates our YesodDispatch instance. It is the second half 51 | -- of the call to mkYesodData which occurs in Foundation.hs. Please see the 52 | -- comments there for more details. 53 | mkYesodDispatch "App" resourcesApp 54 | 55 | -- | This function allocates resources (such as a database connection pool), 56 | -- performs initialization and returns a foundation datatype value. This is also 57 | -- the place to put your migrate statements to have automatic database 58 | -- migrations handled by Yesod. 59 | makeFoundation :: AppSettings -> IO App 60 | makeFoundation appSettings = do 61 | -- Some basic initializations: HTTP connection manager, logger, and static 62 | -- subsite. 63 | appHttpManager <- getGlobalManager 64 | appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger 65 | appStatic <- 66 | (if appMutableStatic appSettings then staticDevel else static) 67 | (appStaticDir appSettings) 68 | 69 | -- We need a log function to create a connection pool. We need a connection 70 | -- pool to create our foundation. And we need our foundation to get a 71 | -- logging function. To get out of this loop, we initially create a 72 | -- temporary foundation without a real connection pool, get a log function 73 | -- from there, and then create the real foundation. 74 | let mkFoundation appConnPool = App {..} 75 | -- The App {..} syntax is an example of record wild cards. For more 76 | -- information, see: 77 | -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html 78 | tempFoundation = mkFoundation $ error "connPool forced in tempFoundation" 79 | logFunc = messageLoggerSource tempFoundation appLogger 80 | 81 | -- Create the database connection pool 82 | pool <- flip runLoggingT logFunc $ createPostgresqlPool 83 | (pgConnStr $ appDatabaseConf appSettings) 84 | (pgPoolSize $ appDatabaseConf appSettings) 85 | 86 | -- Perform database migration using our application's logging settings. 87 | -- runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc 88 | 89 | -- Return the foundation 90 | return $ mkFoundation pool 91 | 92 | -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and 93 | -- applying some additional middlewares. 94 | makeApplication :: App -> IO Application 95 | makeApplication foundation = do 96 | logWare <- makeLogWare foundation 97 | -- Create the WAI application and apply middlewares 98 | appPlain <- toWaiAppPlain foundation 99 | return $ logWare $ defaultMiddlewaresNoLogging appPlain 100 | 101 | makeLogWare :: App -> IO Middleware 102 | makeLogWare foundation = 103 | mkRequestLogger def 104 | { outputFormat = 105 | if appDetailedRequestLogging $ appSettings foundation 106 | then Detailed True 107 | else Apache 108 | (if appIpFromHeader $ appSettings foundation 109 | then FromFallback 110 | else FromSocket) 111 | , destination = Logger $ loggerSet $ appLogger foundation 112 | } 113 | 114 | 115 | -- | Warp settings for the given foundation value. 116 | warpSettings :: App -> Settings 117 | warpSettings foundation = 118 | setPort (appPort $ appSettings foundation) 119 | $ setHost (appHost $ appSettings foundation) 120 | $ setOnException (\_req e -> 121 | when (defaultShouldDisplayException e) $ messageLoggerSource 122 | foundation 123 | (appLogger foundation) 124 | $(qLocation >>= liftLoc) 125 | "yesod" 126 | LevelError 127 | (toLogStr $ "Exception from Warp: " ++ show e)) 128 | defaultSettings 129 | 130 | -- | For yesod devel, return the Warp settings and WAI Application. 131 | getApplicationDev :: IO (Settings, Application) 132 | getApplicationDev = do 133 | settings <- getAppSettings 134 | foundation <- makeFoundation settings 135 | wsettings <- getDevSettings $ warpSettings foundation 136 | app <- makeApplication foundation 137 | return (wsettings, app) 138 | 139 | getAppSettings :: IO AppSettings 140 | getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv 141 | 142 | -- | main function for use by yesod devel 143 | develMain :: IO () 144 | develMain = develMainHelper getApplicationDev 145 | 146 | -- | The @main@ function for an executable running this site. 147 | appMain :: IO () 148 | appMain = do 149 | -- Get the settings from all relevant sources 150 | settings <- loadYamlSettingsArgs 151 | -- fall back to compile-time values, set to [] to require values at runtime 152 | [configSettingsYmlValue] 153 | 154 | -- allow environment variables to override 155 | useEnv 156 | 157 | -- Generate the foundation from the settings 158 | foundation <- makeFoundation settings 159 | 160 | -- Generate a WAI Application from the foundation 161 | app <- makeApplication foundation 162 | 163 | -- Run the application with Warp 164 | runSettings (warpSettings foundation) app 165 | 166 | 167 | -------------------------------------------------------------- 168 | -- Functions for DevelMain.hs (a way to run the app from GHCi) 169 | -------------------------------------------------------------- 170 | getApplicationRepl :: IO (Int, App, Application) 171 | getApplicationRepl = do 172 | settings <- getAppSettings 173 | foundation <- makeFoundation settings 174 | wsettings <- getDevSettings $ warpSettings foundation 175 | app1 <- makeApplication foundation 176 | return (getPort wsettings, foundation, app1) 177 | 178 | shutdownApp :: App -> IO () 179 | shutdownApp _ = return () 180 | 181 | 182 | --------------------------------------------- 183 | -- Functions for use in development with GHCi 184 | --------------------------------------------- 185 | 186 | -- | Run a handler 187 | handler :: Handler a -> IO a 188 | handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h 189 | 190 | -- | Run DB queries 191 | db :: ReaderT SqlBackend Handler a -> IO a 192 | db = handler . runDB 193 | -------------------------------------------------------------------------------- /src/Foundation.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-orphans #-} 2 | 3 | module Foundation where 4 | 5 | import Import.NoFoundation 6 | import Database.Persist.Sql (ConnectionPool, runSqlPool) 7 | import Text.Hamlet (hamletFile) 8 | import Text.Jasmine (minifym) 9 | import Control.Monad.Logger (LogSource) 10 | 11 | -- Used only when in "auth-dummy-login" setting is enabled. 12 | import Yesod.Auth.Dummy 13 | 14 | import Yesod.Auth.OpenId (authOpenId, IdentifierType (Claimed)) 15 | import Yesod.Default.Util (addStaticContentExternal) 16 | import Yesod.Core.Types (Logger) 17 | import qualified Yesod.Core.Unsafe as Unsafe 18 | -- import qualified Data.CaseInsensitive as CI 19 | -- import qualified Data.Text.Encoding as TE 20 | 21 | import AppType 22 | import Routes 23 | 24 | data MenuItem = MenuItem 25 | { menuItemLabel :: Text 26 | , menuItemRoute :: Route App 27 | , menuItemAccessCallback :: Bool 28 | } 29 | 30 | data MenuTypes 31 | = NavbarLeft MenuItem 32 | | NavbarRight MenuItem 33 | 34 | -- This is where we define all of the routes in our application. For a full 35 | -- explanation of the syntax, please see: 36 | -- http://www.yesodweb.com/book/routing-and-handlers 37 | -- 38 | -- Note that this is really half the story; in Application.hs, mkYesodDispatch 39 | -- generates the rest of the code. Please see the following documentation 40 | -- for an explanation for this split: 41 | -- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules 42 | -- 43 | -- This function also generates the following type synonyms: 44 | -- type Handler = HandlerT App IO 45 | -- type Widget = WidgetT App IO () 46 | 47 | -- | A convenient synonym for creating forms. 48 | type Form x = Html -> MForm (HandlerFor App) (FormResult x, Widget) 49 | 50 | -- Please see the documentation for the Yesod typeclass. There are a number 51 | -- of settings which can be configured by overriding methods here. 52 | instance Yesod App where 53 | -- Controls the base of generated URLs. For more information on modifying, 54 | -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot 55 | approot :: Approot App 56 | approot = ApprootRequest $ \app req -> 57 | case appRoot $ appSettings app of 58 | Nothing -> getApprootText guessApproot app req 59 | Just root -> root 60 | 61 | -- Store session data on the client in encrypted cookies, 62 | -- default session idle timeout is 120 minutes 63 | makeSessionBackend :: App -> IO (Maybe SessionBackend) 64 | makeSessionBackend _ = Just <$> defaultClientSessionBackend 65 | 120 -- timeout in minutes 66 | "config/client_session_key.aes" 67 | 68 | -- Yesod Middleware allows you to run code before and after each handler function. 69 | -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. 70 | -- Some users may also want to add the defaultCsrfMiddleware, which: 71 | -- a) Sets a cookie with a CSRF token in it. 72 | -- b) Validates that incoming write requests include that token in either a header or POST parameter. 73 | -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware 74 | -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. 75 | yesodMiddleware :: ToTypedContent res => Handler res -> Handler res 76 | yesodMiddleware = defaultYesodMiddleware 77 | 78 | -- The page to be redirected to when authentication is required. 79 | -- authRoute 80 | -- :: App 81 | -- -> Maybe (Route App) 82 | -- authRoute _ = Just $ AuthR LoginR 83 | 84 | isAuthorized 85 | :: Route App -- ^ The route the user is visiting. 86 | -> Bool -- ^ Whether or not this is a "write" request. 87 | -> Handler AuthResult 88 | -- Routes not requiring authentication. 89 | isAuthorized _ _ = return Authorized 90 | 91 | -- This function creates static content files in the static folder 92 | -- and names them based on a hash of their content. This allows 93 | -- expiration dates to be set far in the future without worry of 94 | -- users receiving stale content. 95 | addStaticContent 96 | :: Text -- ^ The file extension 97 | -> Text -- ^ The MIME content type 98 | -> LByteString -- ^ The contents of the file 99 | -> Handler (Maybe (Either Text (Route App, [(Text, Text)]))) 100 | addStaticContent ext mime content = do 101 | master <- getYesod 102 | let staticDir = appStaticDir $ appSettings master 103 | addStaticContentExternal 104 | minifym 105 | genFileName 106 | staticDir 107 | (StaticR . flip StaticRoute []) 108 | ext 109 | mime 110 | content 111 | where 112 | -- Generate a unique filename based on the content itself 113 | genFileName lbs = "autogen-" ++ base64md5 lbs 114 | 115 | -- What messages should be logged. The following includes all messages when 116 | -- in development, and warnings and errors in production. 117 | shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool 118 | shouldLogIO app _source level = 119 | return $ 120 | appShouldLogAll (appSettings app) 121 | || level == LevelWarn 122 | || level == LevelError 123 | 124 | makeLogger :: App -> IO Logger 125 | makeLogger = return . appLogger 126 | 127 | -- How to run database actions. 128 | instance YesodPersist App where 129 | type YesodPersistBackend App = SqlBackend 130 | runDB :: SqlPersistT Handler a -> Handler a 131 | runDB action = do 132 | master <- getYesod 133 | runSqlPool action $ appConnPool master 134 | 135 | instance YesodPersistRunner App where 136 | getDBRunner :: Handler (DBRunner App, Handler ()) 137 | getDBRunner = defaultGetDBRunner appConnPool 138 | 139 | -- This instance is required to use forms. You can modify renderMessage to 140 | -- achieve customized and internationalized form validation messages. 141 | instance RenderMessage App FormMessage where 142 | renderMessage :: App -> [Lang] -> FormMessage -> Text 143 | renderMessage _ _ = defaultFormMessage 144 | 145 | -- Useful when writing code that is re-usable outside of the Handler context. 146 | -- An example is background jobs that send email. 147 | -- This can also be useful for writing code that works across multiple Yesod applications. 148 | instance HasHttpManager App where 149 | getHttpManager :: App -> Manager 150 | getHttpManager = appHttpManager 151 | 152 | unsafeHandler :: App -> Handler a -> IO a 153 | unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger 154 | 155 | -- Note: Some functionality previously present in the scaffolding has been 156 | -- moved to documentation in the Wiki. Following are some hopefully helpful 157 | -- links: 158 | -- 159 | -- https://github.com/yesodweb/yesod/wiki/Sending-email 160 | -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain 161 | -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding 162 | -------------------------------------------------------------------------------- /src/Handler/Admin.hs: -------------------------------------------------------------------------------- 1 | module Handler.Admin where 2 | 3 | import Import 4 | 5 | import Helpers.Handlers 6 | import Helpers.Views 7 | 8 | getAdminR :: UserId -> Handler Html 9 | getAdminR userId = do 10 | User{..} <- 11 | runDBOr404 (get userId) 12 | let isOrIsNot :: Text 13 | isOrIsNot = 14 | if userIsAdmin 15 | then "IS" 16 | else "IS NOT" 17 | header = 18 | [st|#{userEmail} #{isOrIsNot} an Admin!|] 19 | baseLayout Nothing $ do 20 | setTitle "Home" 21 | [whamlet| 22 |

#{header} 23 |
24 | 25 | |] 26 | 27 | postAdminR :: UserId -> Handler Html 28 | postAdminR userId = do 29 | runDB $ update userId [UserIsAdmin =. True] 30 | redirect $ AdminR userId 31 | -------------------------------------------------------------------------------- /src/Handler/Auth.hs: -------------------------------------------------------------------------------- 1 | module Handler.Auth where 2 | 3 | import Import 4 | 5 | import Handler.Auth.Forms 6 | import Handler.Auth.Views 7 | import Handler.Sessions 8 | import Helpers.Forms 9 | import Helpers.Views 10 | 11 | redirectIfLoggedIn :: (RedirectUrl App r) => r -> Handler () 12 | redirectIfLoggedIn r = do 13 | maybeUser <- getUser 14 | case maybeUser of 15 | Nothing -> return () 16 | (Just _) -> redirect r 17 | 18 | requireUser :: Handler (Entity User) 19 | requireUser = do 20 | maybeUser <- getUser 21 | case maybeUser of 22 | Nothing -> redirect HomeR -- LoginR 23 | (Just user) -> return user 24 | 25 | getLoginR :: Handler Html 26 | getLoginR = do 27 | redirectIfLoggedIn HomeR 28 | (loginFormWidget, _) <- generateFormPost loginForm 29 | renderLogin loginFormWidget 30 | 31 | postLoginR :: Handler Html 32 | postLoginR = do 33 | redirectIfLoggedIn HomeR 34 | ((result, widget), _) <- runFormPost loginForm 35 | case result of 36 | FormSuccess (email, password) -> do 37 | maybeU <- runDB (getUserByEmail email) 38 | case maybeU of 39 | Nothing -> 40 | notFound 41 | (Just (Entity dbUserKey User{..})) -> do 42 | let success = 43 | passwordMatches userPasswordDigest password 44 | case success of 45 | False -> 46 | notAuthenticated 47 | True -> do 48 | setUserSession dbUserKey True 49 | redirect HomeR 50 | _ -> renderLogin widget 51 | 52 | 53 | data SignupForm = SignupForm { 54 | signupEmail :: Text 55 | , signupUsername :: Text 56 | , signupPassword :: Text 57 | } 58 | 59 | signupForm :: Form SignupForm 60 | signupForm = 61 | renderDivs $ 62 | SignupForm 63 | <$> areq textField (named "email" (placeheld "Email: ")) Nothing 64 | <*> areq textField (named "username" (placeheld "Username: ")) Nothing 65 | <*> areq passwordField (named "password" (placeheld "Password: ")) Nothing 66 | 67 | renderSignup :: Widget -> Handler Html 68 | renderSignup widget = do 69 | baseLayout Nothing $ do 70 | setTitle "Signup" 71 | [whamlet| 72 |
73 |
74 |
75 |
76 |
77 |

Signup for an account! 78 | 79 | ^{widget} 80 | 81 | |] 82 | 83 | getSignupR :: Handler Html 84 | getSignupR = do 85 | redirectIfLoggedIn HomeR 86 | (signupFormWidget, _) <- generateFormPost signupForm 87 | renderSignup signupFormWidget 88 | 89 | postSignupR :: Handler Html 90 | postSignupR = do 91 | redirectIfLoggedIn HomeR 92 | ((result, widget), _) <- runFormPost signupForm 93 | case result of 94 | FormSuccess SignupForm{..} -> do 95 | -- Check to see if a user with this email already exists 96 | maybeUP <- runDB (getUserByEmail signupEmail) 97 | case maybeUP of 98 | -- If it does, render the form again (?) 99 | (Just _) -> do 100 | renderSignup widget 101 | -- If not, create a user 102 | Nothing -> do 103 | (Entity dbUserKey _) <- 104 | runDB $ createUser signupEmail signupPassword signupUsername False 105 | setUserSession dbUserKey True 106 | redirect HomeR 107 | _ -> renderSignup widget 108 | 109 | getSignoutR :: Handler Html 110 | getSignoutR = do 111 | deleteLoginData 112 | redirect HomeR 113 | -------------------------------------------------------------------------------- /src/Handler/Auth/Forms.hs: -------------------------------------------------------------------------------- 1 | module Handler.Auth.Forms where 2 | 3 | import Import 4 | 5 | import Helpers.Forms 6 | 7 | -- 8 | -- 9 | --

10 | --

19 | -- 20 | 21 | loginForm :: Form (Text, Text) 22 | loginForm = 23 | renderDivs $ 24 | (,) <$> areq textField (named "email" (placeheld "Email")) Nothing 25 | <*> areq passwordField (named "password" (placeheld "Password")) Nothing 26 | 27 | 28 | renderLoginForm :: Maybe Text -> Widget 29 | renderLoginForm maybeEmail = do 30 | let attrs :: [(Text, Text)] 31 | attrs = [("value", fromMaybe "" maybeEmail)] 32 | [whamlet| 33 | 34 | 35 |

36 |

14 |
15 |
16 | Login 17 | 18 | 19 | ^{renderLoginForm (Just "chris@lol.com")} 20 |

21 | 22 | 23 |

24 | Forgot your password or deleted your account? 25 | 26 | 27 | Reset your password 28 | . 29 | 30 |

31 | Not a user yet? Signup is by invitation only to combat spam and increase 32 | accountability. If you know 33 | 34 | a current user 35 | of the site, 36 | ask them for an invitation or 37 | request one in 38 | 39 | chat 40 | . 41 | |] 42 | 43 | -- 44 | -- 45 | --

46 | --

55 | -- 56 | 57 | --

58 | --
59 | --
60 | --
61 | --
62 | --

Login to your account! 63 | -- 64 | -- ^{widget} 65 | -- 66 | -------------------------------------------------------------------------------- /src/Handler/Comment.hs: -------------------------------------------------------------------------------- 1 | module Handler.Comment where 2 | 3 | import Import hiding ((==.), on) 4 | 5 | import qualified Data.Map as Map 6 | import Data.Time.Clock 7 | import Database.Esqueleto 8 | import Data.Maybe (maybeToList) 9 | 10 | import Handler.Comment.Query 11 | import Handler.Comment.Views 12 | import Helpers.Views 13 | import Model 14 | 15 | getCommentR :: Text -> Text -> Handler Html 16 | getCommentR storyShortId _ = do 17 | baseLayout Nothing $ do 18 | setTitle "Home" 19 | [whamlet| 20 | ^{storyLiner} 21 | ^{renderCommentSubtree undefined undefined undefined undefined} 22 | |] 23 | -------------------------------------------------------------------------------- /src/Handler/Comment/Query.hs: -------------------------------------------------------------------------------- 1 | module Handler.Comment.Query where 2 | 3 | import Import hiding ((==.), on) 4 | 5 | import qualified Data.Map as Map 6 | import Data.Time.Clock 7 | import Database.Esqueleto 8 | import Data.Maybe (maybeToList) 9 | 10 | import Helpers.Views 11 | import Model 12 | 13 | type StoryComments = Map StoryId (Entity Story, [Entity Comment]) 14 | 15 | type CommentTree = 16 | ([Entity Comment], Map CommentId [Entity Comment]) 17 | 18 | -- data RoseTree a = RoseTree a [RoseTree a] 19 | -- [RoseTree (Entity Comment)] 20 | 21 | getStoryAndComments :: Text -> DB StoryComments 22 | getStoryAndComments shortCode = undefined 23 | -------------------------------------------------------------------------------- /src/Handler/Comment/Views.hs: -------------------------------------------------------------------------------- 1 | module Handler.Comment.Views where 2 | 3 | import Import hiding ((==.), on) 4 | 5 | import qualified Data.Map as Map 6 | import Data.Time.Clock 7 | import Database.Esqueleto 8 | import Data.Maybe (maybeToList) 9 | 10 | import Helpers.Views 11 | import Model 12 | 13 | storyLiner :: Widget 14 | storyLiner = [whamlet| 15 |
16 |
17 | 18 |
19 | 19 20 |
21 | 22 | 23 | Is Freedom Zero such a hot idea? 24 | 25 | 26 | law 27 | 28 | sicpers.info 29 |
30 | 31 | leeg avatar 32 | authored by 33 | 34 | 35 | leeg 36 | 37 | 2 days ago 38 | | 39 | 40 | suggest 41 | | 42 | 43 | flag 44 | | 45 | 46 | hide 47 | (hidden by 6 users) 48 | | 49 | 50 | save 51 | | 52 | 53 | 54 | cached 55 | 56 | | 57 | 58 | 59 | 27 60 | comments 61 | 62 | | +23, -1 off-topic, -3 spam 63 | |] 64 | 65 | postTopLevelComment :: Widget 66 | postTopLevelComment = [whamlet| 67 |
    68 |
  1. 69 |
    70 | 71 | 72 | 73 | 74 |
    75 |