code:
(ns jumpluff.poi-message
  (:require [cljs.core.async :as async]
            [clojure.string :as s]
            [jumpluff.state :as state]
            [jumpluff.utils :refer [log
                                    promise-to-chan
                                    server-emoji-id]])
  (:require-macros [cljs.core.async.macros :as async-macros]))

(def discord (js/require "discord.js"))

(def ^:dynamic *page-size* 4)
(def ^:dynamic *msg-map-size* 6)
(def ^:dynamic *enable-reactions* true)

(defn- gps-to-keyless-staticmap-thumbnail [gps]
  (str "https://maps.googleapis.com/maps/api/staticmap?center="
       gps "&zoom=12&size=80x80&markers=size:small%7Ccolor:0xff0000%7Clabel:%7C" gps))

(defn osm [gps zoom tile-server]
  (let [[lat long] (map js/Number (s/split gps #"," 2))
        long2tile (fn [lon zoom]
                    (-> lon
                       (+ 180)
                       (/ 360)
                       (* (.pow js/Math 2 zoom))
                       js/Math.floor))
        lat2tile (fn [lat zoom]
                   (-> (as-> (-> lat
                               (* js/Math.PI)
                               (/ 180))
                          <>
                        (-> (/ 1 (.cos js/Math <>))
                           (+ (.tan js/Math <>))))
                      js/Math.log
                      (/ js/Math.PI)
                      (as-> <> (- 1 <>))
                      (/ 2)
                      (* (.pow js/Math 2 zoom))
                      js/Math.floor))]
    (str tile-server zoom "/"
         (long2tile long zoom) "/"
         (lat2tile lat zoom) ".png")))

(defn thumbnail [gps]
  ;; (gps-to-keyless-staticmap-thumbnail gps)
  (when-let [tiles (not-empty js/process.env.OSM_TILE_SERVER)]
    (osm gps 16 tiles)))

(defn- gps-to-maps-link [gps]
  (str "https://maps.google.com/?daddr=" gps))

(defn- poi-format-name [poi source-message]
  (str (:name poi)
       (when-let [ex (:ex poi)]
         (str " "
              (or (when source-message
                    (get @state/server-emoji
                         (server-emoji-id source-message "ex")))
                  "(EX)")
              (when (= ex :ex-triggered)
                ":tada:")))))

(defn- poi-format-description [poi]
  (str "["
       (or (not-empty (:description poi))
           (:gps poi))
       "](" (gps-to-maps-link (:gps poi)) ")"))

(def msg-map (atom {}))

(defn- add-to-ring
  "`swap! assoc` into `ring`, when count of `ring` reaches `limit`
  `dissoc` the `first`.  Just before dissoc run `cleanup-fn` on the
  trimmed value.  `assoc` adds to the tail of the array-map, so first
  is assumed to be the oldest item. Return `val`."
  [ring limit id val cleanup-fn]
  (when (< (dec limit)
           (count @ring))
    (when-let [[head-id head-val] (first @ring)]
      (cleanup-fn head-val)
      (swap! ring dissoc head-id)))
  (swap! ring assoc id val)
  val)

(defn poi-collection-and-src-msg-to-obj
  "Create and add the msg-map context for `collection` and
  `source-message`."
  [collection source-message]
  (add-to-ring msg-map *msg-map-size*
               source-message.id
               {:collection collection
                :msg-source source-message
                :msg-sent (atom nil)
                :page (atom 0)
                :count-pages (atom 0)
                :count-current-page (atom 0)
                :reaction-collector (atom nil)
                :reaction-in-progress (atom false)
                :presupply-in-progress (atom false)
                :presupply-stop-p (atom false)}
               #(some-> @(:reaction-collector %)
                        (.stop "time"))))

(defn poi-collection-to-message
  "Create a RichEmbed from a msg-map context map."
  ([m]
   (poi-collection-to-message m 0 nil))
  ([m page-n narrow-to-nth]
   (let [embed (discord.RichEmbed.)
         collection-pages (partition *page-size* *page-size* nil (:collection m))
         count-pages (count collection-pages)
         page-number (or (and (int? page-n)
                              (< 0 page-n)
                              (< page-n count-pages)
                              page-n) 0)
         narrow (and (int? narrow-to-nth)
                     (some #{narrow-to-nth} (range *page-size*)))
         current-page (let [p (nth collection-pages page-number [])]
                        (if (and narrow (< narrow (count p)))
                          (list (nth p narrow []))
                          p))
         count-current-page (count current-page)]
     (do (reset! (:page m) (if narrow 0 page-number))
         (reset! (:count-pages m) (if narrow 1 count-pages))
         (reset! (:count-current-page m) count-current-page))
     (when (<= 1 count-current-page)
       (aset embed "fields"
             (clj->js
              (map (fn [poi] {:name (poi-format-name poi (:msg-source m))
                             :value (poi-format-description poi)
                             :inline false})
                   current-page))))
     (when (= 1 count-current-page)
       (let [gps (:gps (first current-page))]
         (.setThumbnail embed (thumbnail gps))
         (.setURL embed (gps-to-maps-link gps))))
     (when (and (not narrow)
                (not= 1 count-pages))
       (.setFooter embed
                   (cond (< 1 count-pages)
                         (str "page "
                              (inc page-number)
                              " out of "
                              count-pages
                              " pages, "
                              (count (:collection m))
                              " results")
                         (zero? count-current-page)
                         "No results found.")))
     embed)))

(def static-reaction-emoji-map
  {"green-done" "✅"
   "del" "🇽"
   "prev" "⬅"
   "digit-1" "1⃣"
   "digit-2" "2⃣"
   "digit-3" "3⃣"
   "digit-4" "4⃣"
   "next" "➡"})

(defn- poimsg-context-reaction-predicates
  "Evaluate if `emoji-name` should be applied given the context map."
  [m emoji-name]
  (case emoji-name
    "digit-1" (< 1 @(:count-current-page m))
    "digit-2" (<= 2 @(:count-current-page m))
    "digit-3" (<= 3 @(:count-current-page m))
    "digit-4" (<= 4 @(:count-current-page m))
    "prev" (< 0 @(:page m))
    "next" (< (inc @(:page m)) ; zero based, vs starts at one
              @(:count-pages m))
    true))

(defn- clear-and-stop-reactions
  "Wrap `.clearReactions`.
  If a presupply reactions call was in progress, interrupt and wait for it.
  Then make the clearReactions call and let the go-block finish."
  [m]
  (async-macros/go
    (when-let [in-progress @(:presupply-in-progress m)]
      (reset! (:presupply-stop-p m) true) ; interrupt presupply
      (async/<! in-progress)) ; wait for presupply to finish
    (some->> @(:msg-sent m)
             (promise-to-chan #(.clearReactions %))
             async/<!)))

(defn- reaction-menu-poi-presupply
  "Add the applicable initial reactions to a point of interest response.
  The discord api does not support multiple reactions being added in a
  bulk call, so this will be a slow process adding one by one.  The
  atom `:presupply-in-progress` will hold the go-block channel when a
  call in progress, reset to false when complete.  To interrupt this
  process, set `:presupply-stop-p` to true and the go-block will
  finish after the call it was making."
  [m]
  (swap! (:presupply-in-progress m)
         (fn [current-value]
           (async-macros/go
             ;; wait for the last run
             (when current-value
               (log "waiting for last run of presupply to wrap up")
               (async/<! current-value))
             (when-let [msg @(:msg-sent m)]
               (let [stopped (atom false)]
                 (doseq [emoji-key (keys static-reaction-emoji-map)]
                   (when (and (not @(:presupply-stop-p m))
                              (poimsg-context-reaction-predicates m emoji-key))
                     (when (not (.-deleted msg))
                       (->> emoji-key
                          (get static-reaction-emoji-map)
                          (promise-to-chan #(.react msg %))
                          async/<!)))
                   (when (and @(:presupply-stop-p m)
                              (not (.-deleted msg))
                              (not @stopped))
                     (reset! stopped true)))) ; hack to stop the doseq, using doseq for <!
               (reset! (:presupply-stop-p m) false)
               (reset! (:presupply-in-progress m) false))))))

(defn- poi-handle-reactions
  "Handle the reaction added event for a msg-map context map"
  [m]
  (fn [reaction]
    (log "—Sent message, "
         [(.-id @(:msg-sent m)) (.-id (:msg-source m))]
         " received: "  reaction.emoji.name)
    (when (some #{(.-author.id (:msg-source m))}
                (map #(.-id %) (.array reaction.users)))
      (swap! (:reaction-in-progress m)
             (fn [current-value]
               (async-macros/go
                 ;; wait for the last run
                 (when current-value
                   (log "waiting for last run")
                   (async/<! current-value))
                 ;; hold up here until finished
                 (cond (= reaction.emoji.name
                          (get static-reaction-emoji-map "green-done"))
                       (do (some-> @(:reaction-collector m)
                                   (.stop "checkmark reaction"))
                           (async/<! (clear-and-stop-reactions m)))
                       (= reaction.emoji.name
                          (get static-reaction-emoji-map "del"))
                       (do (reset! (:msg-sent m) nil) ; dissoc this as the message will be deleted
                           (async/<! (promise-to-chan (.delete reaction.message)))
                           (some-> @(:reaction-collector m)
                                   (.stop "marked for deletion"))
                           (log "—Deleted message")))
                 (doseq [[emoji-name page-n narrow-to-nth]
                         (let [page-n @(:page m)]
                           [["digit-1" page-n 0]
                            ["digit-2" page-n 1]
                            ["digit-3" page-n 2]
                            ["digit-4" page-n 3]
                            ["prev" (dec page-n) nil]
                            ["next" (inc page-n) nil]])]
                   (when (and (= reaction.emoji.name
                                 (get static-reaction-emoji-map emoji-name))
                              (poimsg-context-reaction-predicates m emoji-name))
                     (->> (poi-collection-to-message m page-n narrow-to-nth)
                        (promise-to-chan #(.edit reaction.message %))
                        async/<!)
                     (async/<! (clear-and-stop-reactions m))
                     (async/<! (reaction-menu-poi-presupply m))))
                 (reset! (:reaction-in-progress m) false)))))))

(defn- start-reaction-collector
  [message filter timeout end-cb collect-cb]
  (doto (.createReactionCollector message filter
                                  (clj->js {:time timeout}))
    (.on "end" end-cb)
    (.on "collect" collect-cb)))

(defn poi-once-sent
  "Start the reaction collector on sent responses to `command-name`"
  [sent-message src-message]
  (when-let [m (get @msg-map src-message.id nil)]
    (reset! (:msg-sent m) sent-message)
    (log "—once sent ids:" [sent-message.id src-message.id m])
    (reaction-menu-poi-presupply m)
    (->> (start-reaction-collector @(:msg-sent m)
                                 (fn [reaction user] (not= user.id (.-user.id @state/client)))
                                 (* 3 60 1000) ; min to ms
                                 (fn [collected reason]
                                   (log "—end reaction collector reason: " reason)
                                   (when (= reason "time")
                                     (clear-and-stop-reactions m))
                                   (swap! msg-map dissoc src-message.id))
                                 (poi-handle-reactions m))
       (reset! (:reaction-collector m)))))

(defn cleanup-msg-map
  []
  (async-macros/go
    (doseq [m (vals @msg-map)]
      (async/<! (clear-and-stop-reactions m)))))


code:
(ns jumpluff.state
  (:require [clojure.string :as s]))

(defonce channel-dataset (atom {}))
(defonce dataset-descriptions (atom {}))
(defonce server-emoji (atom {}))

(defonce csv-files (atom {}))
(defonce client (atom nil))

(defonce data-dir (or js/process.env.JUMPLUFF_DATA "data"))
(defonce config-file (or js/process.env.JUMPLUFF_CONFIG
                         "var/config.json"))

(def poi-query-prefixes
  (-> (or (not-empty js/process.env.JUMPLUFF_QUERY_PREFIX)
         "!poi ,p")
     s/trim
     (s/replace #"\s{2,}" " ")
     (s/split " ")))

repo_name: panselia/jumpluff

license: wtfpl


code:
(ns jumpluff.utils
  (:require [cljs.core.async :as async]
            [jumpluff.state :as state])
  (:require-macros [cljs.core.async.macros :as async-macros]))

(defn dataset-names []
  (keys @state/dataset-descriptions))

(defn dataset-names-some-exact-match
  "Use `some` to look for an exact string match of `name` in `dataset-names`"
  [name]
  (some #{name} (dataset-names)))

(defn server-emoji-id [message name]
  (when (not (nil? message.channel.guild))
    (str (.-id message.channel.guild) "/" name)))

(defn promise-to-chan
  "Handle JavaScript Promises with async channels.
  Single argument arity: given a promise, return a chan that will give
  truthy on success, false on error.  Two argument arity: Given a
  `promfn` that produces a promise when given `thing`.  On an error,
  `promise-to-chan` will know how to try again with a new promise."
  ([promise]
   (let [ret (async/chan)
         success #(async/put! ret (or % true))
         failure #(do (console.error %)
                      (async/put! ret false))]
     (-> promise
        (.then success)
        (.catch failure))
     ret))
  ([promfn thing]
   (promise-to-chan promfn thing 0 1 (async/chan)))
  ([promfn thing retry-attempt retry-limit ret]
   (-> (promfn thing)
      (.then #(async/put! ret (or % true)))
      (.catch (fn [err]
                (console.error err)
                (if (and (= "EAI_AGAIN" (.-code err)) ; error codes to retry on
                         (> retry-limit retry-attempt))
                  (promise-to-chan promfn thing
                                   (inc retry-attempt) retry-limit
                                   ret)
                  (async/put! ret false)))))
   ret))

(defn vecs->maps
  "Translate a collection of vectors to a collection of maps.
  Translate `coll` according to `m` containing keys to vector indexes."
  [m coll]
  (map (fn [xs]
         (->> m
            (map (fn [[k v]]
                   {k (when (int? v)
                        (nth xs v nil))}))
            (apply merge)))
       coll))
;; (vecs->maps {:first 0 :second 1 :third 3} '(["a" "b" "c" "d"] ["a" "b" "c"]))
;; ({:first "a", :second "b", :third "d"}
;;  {:first "a", :second "b", :third nil})

(defn log [& strs]
  (println (apply str strs)))


code:
((haskell-mode . ((haskell-indent-spaces . 4)
                  (haskell-process-use-ghci . t)))
 (hamlet-mode . ((hamlet/basic-offset . 4)
                 (haskell-process-use-ghci . t))))

repo_name: vaeringjar/yesod

license: unknown


code:
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
*~
\#*
MyBlog.cabal

path: .gitignore


code:
# About

This project just a boilerplate based on the tutorial
[Making a Blog with Yesod](https://www.youtube.com/watch?v=SadfV-qbVg8)
by Maximilian Tagher, Published 2015 Jan 4.

## Database Setup

After installing Postgres, run:

```
CREATE USER myblog WITH PASSWORD 'myblog';
CREATE DATABASE myblog;
CREATE DATABASE myblog_test;
GRANT ALL ON DATABASE myblog TO myblog;
GRANT ALL ON DATABASE myblog_test TO myblog;
```

## 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 MyBlog:library-only --flag MyBlog: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.


code:
-- | 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 MyBlog: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


code:
{-# LANGUAGE PackageImports #-}
import "MyBlog" Application (develMain)
import Prelude (IO)

main :: IO ()
main = develMain


code:
import Prelude     (IO)
import Application (appMain)

main :: IO ()
main = appMain


code:
# After you've edited this file, remove the following line to allow
# `yesod keter` to build your bundle.
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/MyBlog/MyBlog
    exec: ../dist/bin/MyBlog

    # 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.MyBlog.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.MyBlog.com
    root: ../static

    # Uncomment to turn on directory listings.
    # directory-listing: true

  # Redirect plain domain name to www.
  - type: redirect

    hosts:
      - MyBlog.com
    actions:
      - host: www.MyBlog.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


code:
-- By default this file is used by `persistFileWith` in Model.hs (which is imported by Foundation.hs)
-- Syntax for this file here: https://github.com/yesodweb/persistent/blob/master/docs/Persistent-entity-syntax.md

User
    ident Text
    password Text Maybe
    UniqueUser ident
    deriving Typeable
Email
    email Text
    userId UserId Maybe
    verkey Text Maybe
    UniqueEmail email
Comment json -- Adding "json" causes ToJSON and FromJSON instances to be derived.
    message Text
    userId UserId Maybe
    deriving Eq
    deriving Show

BlogPost
    title Text
    article Markdown

path: config/models


code:
-- 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

/comments CommentR POST

/profile ProfileR GET
/posts/new PostNewR GET POST
/posts/!#BlogPostId PostDetailsR GET

path: config/routes


code:
# 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.
ip-from-header: "_env:YESOD_IP_FROM_HEADER:false"

# Default behavior: determine the application root from the request headers.
# Uncomment to set an explicit approot
#approot:        "_env:YESOD_APPROOT:http://localhost:3000"

# By default, `yesod devel` runs in development, and built executables use
# production settings (see below). To override this, use the following:
#
# development: false

# Optional values with the following production defaults.
# In development, they default to the inverse.
#
# detailed-logging: false
# should-log-all: false
# reload-templates: false
# mutable-static: false
# skip-combining: false
# auth-dummy-login : false

# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:YESOD_PGPASS:'123'")
# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings

database:
  user:     "_env:YESOD_PGUSER:myblog"
  password: "_env:YESOD_PGPASS:myblog"
  host:     "_env:YESOD_PGHOST:localhost"
  port:     "_env:YESOD_PGPORT:5432"
  # See config/test-settings.yml for an override during tests
  database: "_env:YESOD_PGDATABASE:myblog"
  poolsize: "_env:YESOD_PGPOOLSIZE:10"

copyright: Insert copyright statement here
#analytics: UA-YOURCODE


code:
database:
  # NOTE: By design, this setting prevents the PGDATABASE environment variable
  # from affecting test runs, so that we don't accidentally affect the
  # production database during testing. If you're not concerned about that and
  # would like to have environment variable overrides, you could instead use
  # something like:
  #
  #   database: "_env:PGDATABASE:MyBlog_test"
  database: myblog_test

auth-dummy-login: true


code:
name:    MyBlog
version: "0.0.0"

dependencies:

# Due to a bug in GHC 8.0.1, we block its usage
# See: https://ghc.haskell.org/trac/ghc/ticket/12130
- base >=4.8.2.0 && <4.9 || >=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.7
- classy-prelude >=1.4 && <1.5
- classy-prelude-conduit >=1.4 && <1.5
- classy-prelude-yesod >=1.4 && <1.5
- bytestring >=0.9 && <0.11
- text >=0.11 && <2.0
- persistent >=2.8 && <2.9
- persistent-postgresql >=2.8 && <2.9
- persistent-template >=2.5 && <2.9
- template-haskell
- shakespeare >=2.0 && <2.1
- hjsmin >=0.1 && <0.3
- monad-control >=0.3 && <1.1
- wai-extra >=3.0 && <3.1
- yaml >=0.8 && <0.9
- http-client-tls >=0.3 && <0.4
- http-conduit >=2.3 && <2.4
- directory >=1.1 && <1.4
- warp >=3.0 && <3.3
- data-default
- aeson >=0.6 && <1.4
- conduit >=1.0 && <2.0
- monad-logger >=0.3 && <0.4
- fast-logger >=2.2 && <2.5
- wai-logger >=2.2 && <2.4
- file-embed
- safe
- unordered-containers
- containers
- vector
- time
- case-insensitive
- wai
- foreign-store
- markdown
- yesod-text-markdown

# 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:
  MyBlog:
    main: main.hs
    source-dirs: app
    ghc-options:
    - -threaded
    - -rtsopts
    - -with-rtsopts=-N
    dependencies:
    - MyBlog
    when:
    - condition: flag(library-only)
      buildable: false

# Test suite
tests:
  MyBlog-test:
    main: Spec.hs
    source-dirs: test
    ghc-options: -Wall
    dependencies:
    - MyBlog
    - 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


code:
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
    ( getApplicationDev
    , appMain
    , develMain
    , makeFoundation
    , makeLogWare
    -- * for DevelMain
    , getApplicationRepl
    , shutdownApp
    -- * for GHCI
    , handler
    , db
    ) where

import Control.Monad.Logger                 (liftLoc, runLoggingT)
import Database.Persist.Postgresql          (createPostgresqlPool, pgConnStr,
                                             pgPoolSize, runSqlPool)
import Import
import Language.Haskell.TH.Syntax           (qLocation)
import Network.HTTP.Client.TLS              (getGlobalManager)
import Network.Wai (Middleware)
import Network.Wai.Handler.Warp             (Settings, defaultSettings,
                                             defaultShouldDisplayException,
                                             runSettings, setHost,
                                             setOnException, setPort, getPort)
import Network.Wai.Middleware.RequestLogger (Destination (Logger),
                                             IPAddrSource (..),
                                             OutputFormat (..), destination,
                                             mkRequestLogger, outputFormat)
import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
                                             toLogStr)

-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Common
import Handler.Home
import Handler.Comment
import Handler.Profile
import Handler.PostNew
import Handler.PostDetails

-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
-- comments there for more details.
mkYesodDispatch "App" resourcesApp

-- | This function allocates resources (such as a database connection pool),
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO App
makeFoundation appSettings = do
    -- Some basic initializations: HTTP connection manager, logger, and static
    -- subsite.
    appHttpManager <- getGlobalManager
    appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
    appStatic <-
        (if appMutableStatic appSettings then staticDevel else static)
        (appStaticDir appSettings)

    -- We need a log function to create a connection pool. We need a connection
    -- pool to create our foundation. And we need our foundation to get a
    -- logging function. To get out of this loop, we initially create a
    -- temporary foundation without a real connection pool, get a log function
    -- from there, and then create the real foundation.
    let mkFoundation appConnPool = App {..}
        -- The App {..} syntax is an example of record wild cards. For more
        -- information, see:
        -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
        tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
        logFunc = messageLoggerSource tempFoundation appLogger

    -- Create the database connection pool
    pool <- flip runLoggingT logFunc $ createPostgresqlPool
        (pgConnStr  $ appDatabaseConf appSettings)
        (pgPoolSize $ appDatabaseConf appSettings)

    -- Perform database migration using our application's logging settings.
    runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc

    -- Return the foundation
    return $ mkFoundation pool

-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: App -> IO Application
makeApplication foundation = do
    logWare <- makeLogWare foundation
    -- Create the WAI application and apply middlewares
    appPlain <- toWaiAppPlain foundation
    return $ logWare $ defaultMiddlewaresNoLogging appPlain

makeLogWare :: App -> IO Middleware
makeLogWare foundation =
    mkRequestLogger def
        { outputFormat =
            if appDetailedRequestLogging $ appSettings foundation
                then Detailed True
                else Apache
                        (if appIpFromHeader $ appSettings foundation
                            then FromFallback
                            else FromSocket)
        , destination = Logger $ loggerSet $ appLogger foundation
        }

-- | Warp settings for the given foundation value.
warpSettings :: App -> Settings
warpSettings foundation =
      setPort (appPort $ appSettings foundation)
    $ setHost (appHost $ appSettings foundation)
    $ setOnException (\_req e ->
        when (defaultShouldDisplayException e) $ messageLoggerSource
            foundation
            (appLogger foundation)
            $(qLocation >>= liftLoc)
            "yesod"
            LevelError
            (toLogStr $ "Exception from Warp: " ++ show e))
      defaultSettings

-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: IO (Settings, Application)
getApplicationDev = do
    settings <- getAppSettings
    foundation <- makeFoundation settings
    wsettings <- getDevSettings $ warpSettings foundation
    app <- makeApplication foundation
    return (wsettings, app)

getAppSettings :: IO AppSettings
getAppSettings = loadYamlSettings [configSettingsYml] [] useEnv

-- | main function for use by yesod devel
develMain :: IO ()
develMain = develMainHelper getApplicationDev

-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain = do
    -- Get the settings from all relevant sources
    settings <- loadYamlSettingsArgs
        -- fall back to compile-time values, set to [] to require values at runtime
        [configSettingsYmlValue]

        -- allow environment variables to override
        useEnv

    -- Generate the foundation from the settings
    foundation <- makeFoundation settings

    -- Generate a WAI Application from the foundation
    app <- makeApplication foundation

    -- Run the application with Warp
    runSettings (warpSettings foundation) app

--------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the app from GHCi)
--------------------------------------------------------------
getApplicationRepl :: IO (Int, App, Application)
getApplicationRepl = do
    settings <- getAppSettings
    foundation <- makeFoundation settings
    wsettings <- getDevSettings $ warpSettings foundation
    app1 <- makeApplication foundation
    return (getPort wsettings, foundation, app1)

shutdownApp :: App -> IO ()
shutdownApp _ = return ()

---------------------------------------------
-- Functions for use in development with GHCi
---------------------------------------------

-- | Run a handler
handler :: Handler a -> IO a
handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h

-- | Run DB queries
db :: ReaderT SqlBackend Handler a -> IO a
db = handler . runDB


code:
{-# 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 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 = HandlerT App IO
-- type Widget = WidgetT App IO ()
mkYesodData "App" $(parseRoutesFile "config/routes")

-- | 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 :: * -> *).
    (MonadIO 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
            $(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
    isAuthorized PostNewR _ = return Authorized
    isAuthorized (PostDetailsR _) _ = return Authorized

    -- the profile route requires that the user is authenticated, so we
    -- delegate to that function
    isAuthorized ProfileR _ = isAuthenticated

    -- This function creates static content files in the static folder
    -- and names them based on a hash of their content. This allows
    -- expiration dates to be set far in the future without worry of
    -- users receiving stale content.
    addStaticContent
        :: Text  -- ^ The file extension
        -> Text -- ^ The MIME content type
        -> LByteString -- ^ The contents of the file
        -> Handler (Maybe (Either Text (Route App, [(Text, Text)])))
    addStaticContent ext mime content = do
        master <- getYesod
        let staticDir = appStaticDir $ appSettings master
        addStaticContentExternal
            minifym
            genFileName
            staticDir
            (StaticR . flip StaticRoute [])
            ext
            mime
            content
      where
        -- Generate a unique filename based on the content itself
        genFileName lbs = "autogen-" ++ base64md5 lbs

    -- What messages should be logged. The following includes all messages when
    -- in development, and warnings and errors in production.
    shouldLogIO :: App -> LogSource -> LogLevel -> IO Bool
    shouldLogIO app _source level =
        return $
        appShouldLogAll (appSettings app)
            || level == LevelWarn
            || level == LevelError

    makeLogger :: App -> IO Logger
    makeLogger = return . appLogger

-- Define breadcrumbs.
instance YesodBreadcrumbs App where
    -- Takes the route that the user is currently on, and returns a tuple
    -- of the 'Text' that you want the label to display, and a previous
    -- breadcrumb route.
    breadcrumb
        :: Route App  -- ^ The route the user is visiting currently.
        -> Handler (Text, Maybe (Route App))
    breadcrumb HomeR = return ("Home", Nothing)
    breadcrumb (AuthR _) = return ("Login", Just HomeR)
    breadcrumb ProfileR = return ("Profile", Just HomeR)
    breadcrumb  _ = return ("home", Nothing)

-- How to run database actions.
instance YesodPersist App where
    type YesodPersistBackend App = SqlBackend
    runDB :: SqlPersistT Handler a -> Handler a
    runDB action = do
        master <- getYesod
        runSqlPool action $ appConnPool master

instance YesodPersistRunner App where
    getDBRunner :: Handler (DBRunner App, Handler ())
    getDBRunner = defaultGetDBRunner appConnPool

instance YesodAuth App where
    type AuthId App = UserId

    -- Where to send a user after successful login
    loginDest :: App -> Route App
    loginDest _ = HomeR
    -- Where to send a user after logout
    logoutDest :: App -> Route App
    logoutDest _ = HomeR
    -- Override the above two destinations when a Referer: header is present
    redirectToReferer :: App -> Bool
    redirectToReferer _ = True

    authenticate :: (MonadHandler m, HandlerSite m ~ App)
                 => Creds App -> m (AuthenticationResult App)
    authenticate creds = liftHandler $ runDB $ do
        x <- getBy $ UniqueUser $ credsIdent creds
        case x of
            Just (Entity uid _) -> return $ Authenticated uid
            Nothing -> Authenticated <$> insert User
                { userIdent = credsIdent creds
                , userPassword = Nothing
                }

    -- You can add other plugins like Google Email, email or OAuth here
    authPlugins :: App -> [AuthPlugin App]
    authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins
        -- Enable authDummy login if enabled.
        where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app]

-- | Access function to determine if a user is logged in.
isAuthenticated :: Handler AuthResult
isAuthenticated = do
    muid <- maybeAuthId
    return $ case muid of
        Nothing -> Unauthorized "You must login to access this page"
        Just _ -> Authorized

instance YesodAuthPersist App

-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage App FormMessage where
    renderMessage :: App -> [Lang] -> FormMessage -> Text
    renderMessage _ _ = defaultFormMessage

-- Useful when writing code that is re-usable outside of the Handler context.
-- An example is background jobs that send email.
-- This can also be useful for writing code that works across multiple Yesod applications.
instance HasHttpManager App where
    getHttpManager :: App -> Manager
    getHttpManager = appHttpManager

unsafeHandler :: App -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger

-- Note: Some functionality previously present in the scaffolding has been
-- moved to documentation in the Wiki. Following are some hopefully helpful
-- links:
--
-- https://github.com/yesodweb/yesod/wiki/Sending-email
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding


code:
module Handler.Comment where

import Import

postCommentR :: Handler Value
postCommentR = do
    -- requireJsonBody will parse the request body into the appropriate type, or return a 400 status code if the request JSON is invalid.
    -- (The ToJSON and FromJSON instances are derived in the config/models file).
    comment <- (requireJsonBody :: Handler Comment)

    -- The YesodAuth instance in Foundation.hs defines the UserId to be the type used for authentication.
    maybeCurrentUserId <- maybeAuthId
    let comment' = comment { commentUserId = maybeCurrentUserId }

    insertedComment <- runDB $ insertEntity comment'
    returnJson insertedComment


code:
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
-- | Common handler functions.
module Handler.Common where

import Data.FileEmbed (embedFile)
import Import

-- These handlers embed files in the executable at compile time to avoid a
-- runtime dependency, and for efficiency.

getFaviconR :: Handler TypedContent
getFaviconR = do cacheSeconds $ 60 * 60 * 24 * 30 -- cache for a month
                 return $ TypedContent "image/x-icon"
                        $ toContent $(embedFile "config/favicon.ico")

getRobotsR :: Handler TypedContent
getRobotsR = return $ TypedContent typePlain
                    $ toContent $(embedFile "config/robots.txt")


code:
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.Home where

import Import
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Text.Julius (RawJS (..))

-- Define our data that will be used for creating the form.
data FileForm = FileForm
    { fileInfo :: FileInfo
    , fileDescription :: Text
    }

-- This is a handler function for the GET request method on the HomeR
-- resource pattern. All of your resource patterns are defined in
-- config/routes
--
-- The majority of the code you will write in Yesod lives in these handler
-- functions. You can spread them across multiple files if you are so
-- inclined, or create a single monolithic file.

getHomeR :: Handler Html
getHomeR = do
    -- allPosts <- runDB $ selectList [BlogPostTitle >=. "foo", BlogPostTitle !=. "foobar"] [Asc BlogPostId, LimitTo 5]
    -- error "todo"
    allPosts <- runDB $ selectList [] [Desc BlogPostId, LimitTo 50]
    defaultLayout $ do
        $(widgetFile "posts/index")

-- getHomeR :: Handler Html
-- getHomeR = do
--     (formWidget, formEnctype) <- generateFormPost sampleForm
--     let submission = Nothing :: Maybe FileForm
--         handlerName = "getHomeR" :: Text
--     allComments <- runDB $ getAllComments

--     defaultLayout $ do
--         let (commentFormId, commentTextareaId, commentListId) = commentIds
--         aDomId <- newIdent
--         setTitle "Welcome To Yesod!"
--         $(widgetFile "homepage")

-- postHomeR :: Handler Html
-- postHomeR = do
--     ((result, formWidget), formEnctype) <- runFormPost sampleForm
--     let handlerName = "postHomeR" :: Text
--         submission = case result of
--             FormSuccess res -> Just res
--             _ -> Nothing
--     allComments <- runDB $ getAllComments

--     defaultLayout $ do
--         let (commentFormId, commentTextareaId, commentListId) = commentIds
--         aDomId <- newIdent
--         setTitle "Welcome To Yesod!"
--         $(widgetFile "homepage")

-- sampleForm :: Form FileForm
-- sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
--     <$> fileAFormReq "Choose a file"
--     <*> areq textField textSettings Nothing
--     -- Add attributes like the placeholder and CSS classes.
--     where textSettings = FieldSettings
--             { fsLabel = "What's on the file?"
--             , fsTooltip = Nothing
--             , fsId = Nothing
--             , fsName = Nothing
--             , fsAttrs =
--                 [ ("class", "form-control")
--                 , ("placeholder", "File description")
--                 ]
--             }

-- commentIds :: (Text, Text, Text)
-- commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")

-- getAllComments :: DB [Entity Comment]
-- getAllComments = selectList [] [Asc CommentId]


code:
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.PostDetails where

import Import

getPostDetailsR :: BlogPostId -> Handler Html
getPostDetailsR blogPostId = do
    blogPost <- runDB $ get404 blogPostId
    defaultLayout $ do
        $(widgetFile "postDetails/post")


code:
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.PostNew where

import Import
import Yesod.Form.Bootstrap3
import Yesod.Text.Markdown

blogPostForm :: AForm Handler BlogPost
blogPostForm = BlogPost
               <$> areq textField (bfs ("Title" :: Text)) Nothing
               <*> areq markdownField (bfs ("Article" :: Text)) Nothing

getPostNewR :: Handler Html
getPostNewR = do
    (widget, enctype) <- generateFormPost $ renderBootstrap3 BootstrapBasicForm blogPostForm
    defaultLayout $ do
        $(widgetFile "posts/new")

postPostNewR :: Handler Html
postPostNewR = do
    ((res, widget), enctype) <- runFormPost $ renderBootstrap3 BootstrapBasicForm blogPostForm
    case res of
      FormSuccess blogPost -> do
          blogPostId <- runDB $ insert blogPost
          redirect $ PostDetailsR blogPostId
      _ -> defaultLayout $(widgetFile "posts/new")


code:
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.Profile where

import Import

getProfileR :: Handler Html
getProfileR = do
    (_, user) <- requireAuthPair
    defaultLayout $ do
        setTitle . toHtml $ userIdent user <> "'s User page"
        $(widgetFile "profile")


code:
module Import
    ( module Import
    ) where

import Foundation            as Import
import Import.NoFoundation   as Import


code:
{-# LANGUAGE CPP #-}
module Import.NoFoundation
    ( module Import
    ) where

import ClassyPrelude.Yesod   as Import
import Model                 as Import
import Settings              as Import
import Settings.StaticFiles  as Import
import Yesod.Auth            as Import
import Yesod.Core.Types      as Import (loggerSet)
import Yesod.Default.Config2 as Import


code:
{-# LANGUAGE EmptyDataDecls             #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
module Model where

import ClassyPrelude.Yesod
import Database.Persist.Quasi
import Text.Markdown (Markdown)
import Yesod.Text.Markdown

-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
-- at:
-- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlSettings, mkMigrate "migrateAll"]
    $(persistFileWith lowerCaseSettings "config/models")


code:
{-# LANGUAGE CPP               #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TemplateHaskell   #-}
-- | Settings are centralized, as much as possible, into this file. This
-- includes database connection settings, static file locations, etc.
-- In addition, you can configure a number of different aspects of Yesod
-- by overriding methods in the Yesod typeclass. That instance is
-- declared in the Foundation.hs file.
module Settings where

import           ClassyPrelude.Yesod
import qualified Control.Exception           as Exception
import           Data.Aeson                  (Result (..), fromJSON, withObject,
                                              (.!=), (.:?))
import           Data.FileEmbed              (embedFile)
import           Data.Yaml                   (decodeEither')
import           Database.Persist.Postgresql (PostgresConf)
import           Language.Haskell.TH.Syntax  (Exp, Name, Q)
import           Network.Wai.Handler.Warp    (HostPreference)
import           Yesod.Default.Config2       (applyEnvValue, configSettingsYml)
import           Yesod.Default.Util          (WidgetFileSettings,
                                              widgetFileNoReload,
                                              widgetFileReload)

-- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files,
-- theoretically even a database.
data AppSettings = AppSettings
    { appStaticDir              :: String
    -- ^ Directory from which to serve static files.
    , appDatabaseConf           :: PostgresConf
    -- ^ Configuration settings for accessing the database.
    , appRoot                   :: Maybe Text
    -- ^ Base for all generated URLs. If @Nothing@, determined
    -- from the request headers.
    , appHost                   :: HostPreference
    -- ^ Host/interface the server should bind to.
    , appPort                   :: Int
    -- ^ Port to listen on
    , appIpFromHeader           :: Bool
    -- ^ Get the IP address from the header when logging. Useful when sitting
    -- behind a reverse proxy.

    , appDetailedRequestLogging :: Bool
    -- ^ Use detailed request logging system
    , appShouldLogAll           :: Bool
    -- ^ Should all log messages be displayed?
    , appReloadTemplates        :: Bool
    -- ^ Use the reload version of templates
    , appMutableStatic          :: Bool
    -- ^ Assume that files in the static dir may change after compilation
    , appSkipCombining          :: Bool
    -- ^ Perform no stylesheet/script combining

    -- Example app-specific configuration values.
    , appCopyright              :: Text
    -- ^ Copyright text to appear in the footer of the page
    , appAnalytics              :: Maybe Text
    -- ^ Google Analytics code

    , appAuthDummyLogin         :: Bool
    -- ^ Indicate if auth dummy login should be enabled.
    }

instance FromJSON AppSettings where
    parseJSON = withObject "AppSettings" $ \o -> do
        let defaultDev =
#ifdef DEVELOPMENT
                True
#else
                False
#endif
        appStaticDir              <- o .: "static-dir"
        appDatabaseConf           <- o .: "database"
        appRoot                   <- o .:? "approot"
        appHost                   <- fromString <$> o .: "host"
        appPort                   <- o .: "port"
        appIpFromHeader           <- o .: "ip-from-header"

        dev                       <- o .:? "development"      .!= defaultDev

        appDetailedRequestLogging <- o .:? "detailed-logging" .!= dev
        appShouldLogAll           <- o .:? "should-log-all"   .!= dev
        appReloadTemplates        <- o .:? "reload-templates" .!= dev
        appMutableStatic          <- o .:? "mutable-static"   .!= dev
        appSkipCombining          <- o .:? "skip-combining"   .!= dev

        appCopyright              <- o .:  "copyright"
        appAnalytics              <- o .:? "analytics"

        appAuthDummyLogin         <- o .:? "auth-dummy-login"      .!= dev

        return AppSettings {..}

-- | Settings for 'widgetFile', such as which template languages to support and
-- default Hamlet settings.
--
-- For more information on modifying behavior, see:
--
-- https://github.com/yesodweb/yesod/wiki/Overriding-widgetFile
widgetFileSettings :: WidgetFileSettings
widgetFileSettings = def

-- | How static files should be combined.
combineSettings :: CombineSettings
combineSettings = def

-- The rest of this file contains settings which rarely need changing by a
-- user.

widgetFile :: String -> Q Exp
widgetFile = (if appReloadTemplates compileTimeAppSettings
                then widgetFileReload
                else widgetFileNoReload)
              widgetFileSettings

-- | Raw bytes at compile time of @config/settings.yml@
configSettingsYmlBS :: ByteString
configSettingsYmlBS = $(embedFile configSettingsYml)

-- | @config/settings.yml@, parsed to a @Value@.
configSettingsYmlValue :: Value
configSettingsYmlValue = either Exception.throw id
                       $ decodeEither' configSettingsYmlBS

-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.
compileTimeAppSettings :: AppSettings
compileTimeAppSettings =
    case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
        Error e -> error e
        Success settings -> settings

-- The following two functions can be used to combine multiple CSS or JS files
-- at compile time to decrease the number of http requests.
-- Sample usage (inside a Widget):
--
-- > $(combineStylesheets 'StaticR [style1_css, style2_css])

combineStylesheets :: Name -> [Route Static] -> Q Exp
combineStylesheets = combineStylesheets'
    (appSkipCombining compileTimeAppSettings)
    combineSettings

combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts'
    (appSkipCombining compileTimeAppSettings)
    combineSettings


code:
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell   #-}
module Settings.StaticFiles where

import Settings     (appStaticDir, compileTimeAppSettings)
import Yesod.Static (staticFiles)

-- This generates easy references to files in the static directory at compile time,
-- giving you compile-time verification that referenced files exist.
-- Warning: any files added to your static directory during run-time can't be
-- accessed this way. You'll have to use their FilePath or URL to access them.
--
-- For example, to refer to @static/js/script.js@ via an identifier, you'd use:
--
--     js_script_js
--
-- If the identifier is not available, you may use:
--
--     StaticFile ["js", "script.js"] []
staticFiles (appStaticDir compileTimeAppSettings)


code:
# This file was automatically generated by 'stack init'
#
# Some commonly used options have been documented as comments in this file.
# For advanced use and comprehensive documentation of the format, please see:
# https://docs.haskellstack.org/en/stable/yaml_configuration/

# Resolver to choose a 'specific' stackage snapshot or a compiler version.
# A snapshot resolver dictates the compiler version and the set of packages
# to be used for project dependencies. For example:
#
# resolver: lts-3.5
# resolver: nightly-2015-09-21
# resolver: ghc-7.10.2
# resolver: ghcjs-0.1.0_ghc-7.10.2
#
# The location of a snapshot can be provided as a file or url. Stack assumes
# a snapshot provided as a file might change, whereas a url resource does not.
#
# resolver: ./custom-snapshot.yaml
# resolver: https://example.com/snapshots/2018-01-01.yaml
resolver: lts-12.10

# User packages to be built.
# Various formats can be used as shown in the example below.
#
# packages:
# - some-directory
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
# - location:
#    git: https://github.com/commercialhaskell/stack.git
#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
#  subdirs:
#  - auto-update
#  - wai
packages:
- .
# Dependency packages to be pulled from upstream that are not in the resolver
# using the same syntax as the packages field.
# (e.g., acme-missiles-0.3)
# extra-deps: []

# Override default flag values for local packages and extra-deps
# flags: {}

# Extra package databases containing global packages
# extra-package-dbs: []

# Control whether we use the GHC we find on the path
# system-ghc: true
#
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: ">=1.7"
#
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
#
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]
#
# Allow a newer minor version of GHC than the snapshot specifies
# compiler-check: newer-minor