[Haskell-cafe] working off a Yesod example file, need help lifting values from one monad into another. (and probably other things too).

Tue Mar 29 02:28:41 CEST 2011

I'm working off of a example file from Yesod, ajax.lhs
I've made an important change in types, and this has resulted in
having to make the old code conform to the change. I will point out
the specifics, then present my question. In the event I failed to
include important information, I will paste in my code as well as the
prototype.

[Original]

> getHomeR :: Handler ()
> getHomeR = do
>   Ajax pages _ <- getYesod
>   let first = head pages
>   redirect RedirectTemporary $ PageR $ pageSlug first

[Changed]

> getHomeR :: Handler ()
> getHomeR = do
>   Tframe pages _ <- getYesod
>   let first = head pages
>   redirect RedirectTemporary $ PageR $ pageSlug first

Error Message

test.lhs:62:4:
    Constructor `Tframe' should have 2 arguments, but has been given 1
    In the pattern: Tframe pages
    In a stmt of a 'do' expression: Tframe pages <- getYesod   ****
This is not what I wrote *****
    In the expression:
        do { Tframe pages <- getYesod;
             content <- widgetToPageContent widget;
             hamletToRepHtml
               (hamlet-0.7.1:Text.Hamlet.Quasi.toHamletValue
                  (do { (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
                       . preEscapedString)
                          "<!DOCTYPE html><html><head><title>";
                        (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
                       . Text.Blaze.toHtml)
                          (Main.pageTitle content);
                        .... })) }

As far as I can tell, I only made a cosmetic change. I don't know
what's going on here.

[Original]

> data Page = Page
>   { pageName :: String
>   , pageSlug :: String
>   , pageContent :: String     ******** I'm going to change this **********
>   }

[Changed]

> data Page = Page
>       { pageTitle :: String
>       , pageSlug :: String -- ^ used in the URL
>       , pageContent :: IO String           ******** This is the change *******
>       }

Here's where I run into trouble

[Original]
>   json page = jsonMap
>       [ ("name", jsonScalar $ pageName page)
>       , ("content", jsonScalar $ pageContent page)   ******** I'm going to change this ********
>       ]

[My changes]

>   json page = jsonMap
>       [ ("name", jsonScalar $ Main.pageTitle page)
>       , ("content", jsonScalar $ liftIO $ pageContent page) ******* This is the change ***********
>       ]

Here's the compiler error

test.lhs:107:35:
    Couldn't match expected type `Char' against inferred type `[Char]'
      Expected type: String
      Inferred type: [String]
    In the second argument of `($)', namely `liftIO $ pageContent page'
    In the expression: jsonScalar $ liftIO $ pageContent page
Failed, modules loaded: none.

I'd appreciate a discussion about why this is wrong, and perhaps clues
as to what is right.

Last problem, stemming from the change in type to IO String. I don't
have a clue as to what change I should make.

test.lhs:100:25:
    No instance for (Text.Blaze.ToHtml (IO String))
      arising from a use of `Text.Blaze.toHtml'
                   at test.lhs:(100,25)-(103,3)
    Possible fix:
      add an instance declaration for (Text.Blaze.ToHtml (IO String))
    In the second argument of `(.)', namely `Text.Blaze.toHtml'
    In a stmt of a 'do' expression:
        (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
       . Text.Blaze.toHtml)
          (pageContent page)
    In the first argument of
`hamlet-0.7.1:Text.Hamlet.Quasi.toHamletValue', nam

                          ely
        `do { (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
             . preEscapedString)
                "<h1>";
              (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
             . Text.Blaze.toHtml)
                (Main.pageTitle page);
              (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
             . preEscapedString)
                "</h1><article>";
              (hamlet-0.7.1:Text.Hamlet.Quasi.htmlToHamletMonad
             . Text.Blaze.toHtml)
                (pageContent page);
              .... }'

And finally, both files can be found below, if it is necessary to look at them.

[Original]

We're going to write a very simple AJAX application. It will be a
simple site with a few pages and a navbar; when you have Javascript,
clicking on the links will load the pages via AJAX. Otherwise, it will
use static HTML.

We're going to use jQuery for the Javascript, though anything would
work just fine. Also, the AJAX responses will be served as JSON. Let's
get started.

> {-# LANGUAGE ScopedTypeVariables, TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses #-}
> import Yesod
> import Yesod.Helpers.Static
> import Data.Monoid (mempty)

Like the blog example, we'll define some data first.

> data Page = Page
>   { pageName :: String
>   , pageSlug :: String
>   , pageContent :: String
>   }

> loadPages :: IO [Page]
> loadPages = return
>   [ Page "Page 1" "page-1" "My first page"
>   , Page "Page 2" "page-2" "My second page"
>   , Page "Page 3" "page-3" "My third page"
>   ]

 loadPages :: IO [Page]
 loadPages = do

>
> data Ajax = Ajax
>   { ajaxPages :: [Page]
>   , ajaxStatic :: Static
>   }
> type Handler = GHandler Ajax Ajax

Next we'll generate a function for each file in our static folder.
This way, we get a compiler warning when trying to using a file which
does not exist.

> staticFiles "static/yesod/ajax"

Now the routes; we'll have a homepage, a pattern for the pages, and
use a static subsite for the Javascript and CSS files.

> mkYesod "Ajax" [$parseRoutes|
> /                  HomeR   GET
> /page/#String      PageR   GET
> /static            StaticR Static ajaxStatic
> |]

<p>That third line there is the syntax for a subsite: Static is the
datatype for the subsite argument; siteStatic returns the site itself
(parse, render and dispatch functions); and ajaxStatic gets the
subsite argument from the master argument.</p>

Now, we'll define the Yesod instance. We'll still use a dummy
approot value, but we're also going to define a default layout.

> instance Yesod Ajax where
>   approot _ = ""
>   defaultLayout widget = do
>   Ajax pages _ <- getYesod
>   content <- widgetToPageContent widget
>   hamletToRepHtml [$hamlet|
> \<!DOCTYPE html>
>
> <html>
>   <head>
>     <title>#{pageTitle content}
>     <link rel="stylesheet" href="@{StaticR style_css}">
>     <script src="http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js">
>     <script src="@{StaticR script_js}">
>     \^{pageHead content}
>   <body>
>     <ul id="navbar">
>       $forall page <- pages
>         <li>
>           <a href="@{PageR (pageSlug page)}">#{pageName page}
>     <div id="content">
>       \^{pageBody content}
> |]

The Hamlet template refers to style_css and style_js; these were
generated by the call to staticFiles above. There's nothing
Yesod-specific about the <a
href="/static/yesod/ajax/style.css">style.css</a> and <a
href="/static/yesod/ajax/script.js">script.js</a> files, so I won't
describe them here.

Now we need our handler functions. We'll have the homepage simply
redirect to the first page, so:

> getHomeR :: Handler ()
> getHomeR = do
>   Ajax pages _ <- getYesod
>   let first = head pages
>   redirect RedirectTemporary $ PageR $ pageSlug first

And now the cool part: a handler that returns either HTML or JSON
data, depending on the request headers.

> getPageR :: String -> Handler RepHtmlJson
> getPageR slug = do
>   Ajax pages _ <- getYesod
>   case filter (\e -> pageSlug e == slug) pages of
>       [] -> notFound
>       page:_ -> defaultLayoutJson (do
>           setTitle $ string $ pageName page
>           addHamlet $ html page
>           ) (json page)
>  where
>   html page = [$hamlet|
> <h1>#{pageName page}
> <article>#{pageContent page}
> |]
>   json page = jsonMap
>       [ ("name", jsonScalar $ pageName page)
>       , ("content", jsonScalar $ pageContent page)
>       ]

We first try and find the appropriate Page, returning a 404 if it's
not there. We then use the applyLayoutJson function, which is really
the heart of this example. It allows you an easy way to create
responses that will be either HTML or JSON, and which use the default
layout in the HTML responses. It takes four arguments: 1) the title of
the HTML page, 2) some value, 3) a function from that value to a
Hamlet value, and 4) a function from that value to a Json value.

Under the scenes, the Json monad is really just using the Hamlet
monad, so it gets all of the benefits thereof, namely interleaved IO
and enumerator output. It is pretty straight-forward to generate JSON
output by using the three functions jsonMap, jsonList and jsonMap. One
thing to note: the input to jsonScalar must be HtmlContent; this helps
avoid cross-site scripting attacks, by ensuring that any HTML entities
will be escaped.

And now our typical main function. We need two parameters to build
our Ajax value: the pages, and the static loader. We'll load up from a
local directory.

> main :: IO ()
> main = do
>
>   pages <- loadPages
>   let s = static "static/yesod/ajax"
>   warpDebug 3000 $ Ajax pages s

[My changes]
> {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses
>  #-}
> import Yesod
> import Yesod.Helpers.Static
> import System.Environment
> import System.IO
> import System.Directory
> import System.FilePath.Posix
> import Control.Applicative
> import Data.List.Split

> data Page = Page
>       { pageTitle :: String
>       , pageSlug :: String -- ^ used in the URL
>       , pageContent :: IO String
>       }

> loadPage :: IO [Page]
> loadPage = do
>  let directoryPath = "/home/mlitchard/playground/webTests/files"
>  let processedPath = map (directoryPath </>) . filter (`notElem` [".",".."])
>  pageFileNames <- processedPath <$> getDirectoryContents directoryPath
>  let pageFiles = map readFile pageFileNames
>  return $ zipWith popEntries pageFileNames pageFiles

-- >  return $ zipWith popEntries

> popEntries :: FilePath -> IO String -> Page
> popEntries pageFileName pageFile =
>   let pageT = last $ splitOn "/" pageFileName
>       pageS = "Job" ++ pageT
>   in  Page { Main.pageTitle=pageT,
>              pageSlug=pageS,
>              pageContent=pageFile }

> data Tframe = Tframe
>   { tframePages :: [Page]
>   , tframeStatic :: Static
>   }

> type Handler = GHandler Tframe Tframe

> staticFiles "static/yesod/ajax"

Routes

> mkYesod "Tframe" [$parseRoutes|
> /                    HomeR   GET
> /page/#String        PageR   GET
> /static              StaticR Static tframeStatic
> |]

defining the Yesod instance

> instance Yesod Tframe where
>   approot _ = ""
>   defaultLayout widget = do
>   Tframe pages <- getYesod
>   content <- widgetToPageContent widget
>   hamletToRepHtml [$hamlet|
> \<!DOCTYPE html>
>
> <html>
>   <head>
>     <title>#{Main.pageTitle content}
>     <link rel="stylesheet" href="@{StaticR style_css}">
>     <script src="http://ajax.googleapis.com/ajax/libs/jquery/1.4.2/jquery.min.js">
>     <script src="@{StaticR script_js}">
>     \^{pageHead content}
>   <body>
>     <ul id="navbar">
>       $forall page <- pages
>         <li>
>           <a href="@{PageR (pageSlug page)}">#{Main.pageTitle page}
>     <div id="content">
>       \^{pageBody content}
> |]

> getHomeR :: Handler ()
> getHomeR = do
>   Tframe pages _ <- getYesod
>   let first = head pages
>   redirect RedirectTemporary $ PageR $ pageSlug first

> getPageR :: String -> Handler RepHtmlJson
> getPageR slug = do
>   Tframe pages _ <- getYesod
>   case filter (\e -> pageSlug e == slug) pages of
>       [] -> notFound
>       page:_ -> defaultLayoutJson (do
>           setTitle $ string $ Main.pageTitle page
>           addHamlet $ html page
>           ) (json page)
>  where
>   html page = [$hamlet|
> <h1>#{Main.pageTitle page}
> <article>#{pageContent page}
> |]

>   json page = jsonMap
>       [ ("name", jsonScalar $ Main.pageTitle page)
>       , ("content", jsonScalar $ liftIO $ pageContent page)
>       ]

> main :: IO ()
> main = do
>
>   pages <- loadPage
>   let s = static "static/yesod/ajax"
>   warpDebug 3000 $ Tframe pages s

If you've read to the bottom, thanks for your patience. I appreciate
any illumination you can send my way.

Michael