{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module Main where

import Control.Applicative ((<$>), optional)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text.Lazy (unpack)
import Happstack.Lite
import Text.Blaze.Html5 (Html, (!), a, form, input, p, toHtml, label)
import Text.Blaze.Html5.Attributes (action, enctype, href, name, size, type_, value)
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A

-- | To start the app we call the `serve` function. The first argument
-- is an optional configuration parameter. The second argument is our
-- web application:
main :: IO ()
main = serve Nothing myApp

-- | The top-level of our application is just a bunch of routes mappings to handlers.
--
-- `dir` is guard used to match on static path components. For
-- example, `dir "echo"`, will match on http://localhost:8000/echo. To
-- match on `"/foo/bar"` you would write, `dir "foo" $ dir "bar" $
-- handler`.
--
-- Each of the routes is tried until one successfully returns a
-- value. In this case, a `Response`.
--
-- We convert the list of handlers in a single handler using `msum`.
--
-- The last handler, `homePage` is not guarded by anything, so it will
-- always be called if none of the other handlers were successful.

myApp :: ServerPart Response
myApp = msum
  [ dir "echo"    $ echo
  , dir "query"   $ queryParams
  , dir "form"    $ formPage
  , dir "fortune" $ fortune
  , dir "files"   $ fileServing
  , dir "upload"  $ upload
  , homePage
  ]

-- | Since this is a web application, we are going to want to create
-- some HTML pages. We will do that using blaze-html. A blaze tutorial
-- can be found here:
--
-- <a href="http://jaspervdj.be/blaze/tutorial.html">http://jaspervdj.be/blaze/tutorial.html</a>
--
-- I like to make a template function which captures common elements
-- of pages in my web app, such as importing style sheets, external
-- javascript files, menus, etc. For this tutorial we have a very
-- simple template:
template :: Text -> Html -> Response
template title body = toResponse $
  H.html $ do
    H.head $ do
      H.title (toHtml title)
    H.body $ do
      body
      p $ a ! href "/" $ "back home"

-- | `ok` tells the server to return the page with the HTTP response
-- code '200 OK'. There are other helper functions like `notFound` and
-- `seeOther` for other response codes. Or use `setResponseCode` to
-- specify a response code by number.
homePage :: ServerPart Response
homePage =
    ok $ template "home page" $ do
           H.h1 "Hello!"
           H.p "Writing applications with happstack-lite is fast and simple!"
           H.p "Check out these killer apps."
           H.p $ a ! href "/echo/secret%20message"  $ "echo"
           H.p $ a ! href "/query?foo=bar" $ "query parameters"
           H.p $ a ! href "/form"          $ "form processing"
           H.p $ a ! href "/fortune"       $ "(fortune) cookies"
           H.p $ a ! href "/files"         $ "file serving"
           H.p $ a ! href "/upload"        $ "file uploads"

-- | The `dir` function only matches on static path segments. If we have
-- a dynamic path segment, we can use the `path` function to capture
-- the value and optionally convert it to another type such as
-- Integer. In this example we just echo the captured path segment in
-- the html. For example, trying visiting:
--
-- <a href="http://localhost:8000/echo/fantastic">http://localhost:8000/echo/fantastic</a>
echo :: ServerPart Response
echo =
    path $ \(msg :: String) ->
        ok $ template "echo" $ do
          p $ "echo says: " >> toHtml msg
          p "Change the url to echo something else."

-- We can also extract values from the query string part of the URL. The
-- query string is the part that looks like "?foo=bar". Trying visiting:
--
-- <a href="http://localhost:8000/query?foo=bar">http://localhost:8000/query?foo=bar</a>
--
-- `lookText` will normally fail (by calling `mzero`) if the parameter
-- is not found. In this example we used `optional` from
-- `Control.Applicative` so that it will return a `Maybe` value
-- instead.
queryParams :: ServerPart Response
queryParams =
    do mFoo <- optional $ lookText "foo"
       ok $ template "query params" $ do
         p $ "foo is set to: " >> toHtml (show mFoo)
         p $ "change the url to set it to something else."

-- | We can use `lookText` (and friends) to extract values from forms
-- as well.
--
-- We use the same `lookText` function from the previous section to
-- look up values in in form data.
--
-- You will also note that we use the `method` function to select
-- between a `GET` request and a `POST` request.
--
-- When the user first views the form, the browser will request
-- "/form" using the `GET` method. In the form tag, we see that the
-- form will also be submitted to "/form" when the user presses the
-- submit button. But in the form tag we have set the method attribute
-- to `POST`.
formPage :: ServerPart Response
formPage = msum [ viewForm, processForm ]
  where
    viewForm :: ServerPart Response
    viewForm =
        do method GET
           ok $ template "form" $
              form ! action "/form" ! enctype "multipart/form-data" ! A.method "POST" $ do
                label ! A.for "msg" $ "Say something clever"
                input ! type_ "text" ! A.id "msg" ! name "msg"
                input ! type_ "submit" ! value "Say it!"

    processForm :: ServerPart Response
    processForm =
        do method POST
           msg <- lookText "msg"
           ok $ template "form" $ do
             H.p "You said:"
             H.p (toHtml msg)

-- | This example extends the form example to save the message in a
-- cookie. That means you can navigate away from the page and when you
-- come back later it will remember the message you saved.
--
-- There are only a few new things in this example compared to the form example.
--
--  1. `lookCookieValue` works just like `lookText`, except it looks
--  for the value in the cookies instead of request paramaters or form
--  data.
--
--  2. `addCookies` sends cookies to the browser. addCookies has the
--  type: `addCookies :: [(CookieLife, Cookie)] -> ServerPart ()`
--
--  3. `CookieLife` specifies how long the cookie is valid. `Session`
--  means it is only valid until the browser window is closed.
--
--  4. `mkCookie` takes the cookie name and the cookie value and makes
--  a `Cookie`.
--
--  5. `seeOther` (aka, 303 redirect) tells the browser to do a new
--  GET request on "/fortune".
fortune :: ServerPart Response
fortune = msum [ viewFortune, updateFortune ]
    where
      viewFortune :: ServerPart Response
      viewFortune =
          do method GET
             mMemory <- optional $ lookCookieValue "fortune"
             let memory = fromMaybe "Your future will be filled with web programming." mMemory
             ok $ template "fortune" $ do
                    H.p "The message in your (fortune) cookie says:"
                    H.p (toHtml memory)
                    form ! action "/fortune" ! enctype "multipart/form-data" ! A.method "POST" $ do
                    label ! A.for "fortune" $ "Change your fortune: "
                    input ! type_ "text" ! A.id "fortune" ! name "new_fortune"
                    input ! type_ "submit" ! value "Say it!"

      updateFortune :: ServerPart Response
      updateFortune =
          do method POST
             fortune <- lookText "new_fortune"
             addCookies [(Session, mkCookie "fortune" (unpack fortune))]
             seeOther ("/fortune" :: String) (toResponse ())

-- | In most web applications, we will want to serve static files from the
-- disk such as images, stylesheets, javascript, etc. We can do
-- that using the `serveDirectory` function.
--
-- The first argument specifies whether `serveDirectory` should create
-- directory listings or not.
--
-- The second argument is a list of index files. If the user requests
-- a directory and the directory contains a index file (in this
-- example "index.html"), then the server will display that index file
-- instead of a directory listing.
--
-- The third argument is the path to the directory we want to serve
-- files from. Here we serve files from the current directory.
--
-- On support platforms (Linux, OS X, Windows), the `serveDirectory`
-- function will automatically use sendfile() to serve the
-- files. sendfile() uses low-level kernel operations to transfer
-- files directly from the disk to the network with minimal CPU usage
-- and maximal bandwidth usage.
fileServing :: ServerPart Response
fileServing =
    serveDirectory EnableBrowsing ["index.html"] "."

-- | Handling file uploads is very straight forward. We create a form,
-- just as before. Except instead of `lookText` we use `lookFile`.
--
-- When a file is uploaded, we store it in a temporary location. The
-- temporary file will automatically be deleted after the server has
-- sent the response. That ensures that unused files don't clutter up
-- the disk.
--
-- In most cases, you don't want a user to upload a file just to have
-- it deleted. Normally the upload handler would use `moveFile` or
-- `copyFile` to move (or copy) the temporary file to a permanent
-- location.
upload :: ServerPart Response
upload =
       msum [ uploadForm
            , handleUpload
            ]
    where
    uploadForm :: ServerPart Response
    uploadForm =
        do method GET
           ok $ template "upload form" $ do
             form ! enctype "multipart/form-data" ! A.method "POST" ! action "/upload" $ do
               input ! type_ "file" ! name "file_upload" ! size "40"
               input ! type_ "submit" ! value "upload"

    handleUpload :: ServerPart Response
    handleUpload =
        do (tmpFile, uploadName, contentType) <- lookFile "file_upload"
           ok $ template "file uploaded" $ do
                p (toHtml $ "temporary file: " ++ tmpFile)
                p (toHtml $ "uploaded name:  " ++ uploadName)
                p (toHtml $ "content-type:   " ++ show contentType)