Removed examples
This commit is contained in:
Michael Snoyman
parent
dda3140695
commit
9dbf6971ad
@ -24,8 +24,6 @@ import Test.Framework (testGroup, Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
||||
import Test.HUnit hiding (Test)
|
||||
import Test.QuickCheck
|
||||
import Control.Monad (when)
|
||||
#endif
|
||||
|
||||
-- | Equality is determined by converting to a 'String' via
|
||||
|
||||
@ -29,11 +29,8 @@ import Yesod.Content
|
||||
#if TEST
|
||||
import Test.Framework (testGroup, Test)
|
||||
import Test.Framework.Providers.HUnit
|
||||
import Test.Framework.Providers.QuickCheck2 (testProperty)
|
||||
import Test.HUnit hiding (Test)
|
||||
import Test.QuickCheck
|
||||
import Data.Text.Lazy (unpack)
|
||||
import qualified Data.Text as T
|
||||
#endif
|
||||
|
||||
newtype Json url a = Json { unJson :: Hamlet url IO a }
|
||||
@ -93,9 +90,9 @@ caseSimpleOutput :: Assertion
|
||||
caseSimpleOutput = do
|
||||
let j = do
|
||||
jsonMap
|
||||
[ (jsonScalar $ T.pack "foo" , jsonList
|
||||
[ jsonScalar $ T.pack "bar"
|
||||
, jsonScalar $ T.pack "baz"
|
||||
[ ("foo" , jsonList
|
||||
[ jsonScalar $ Encoded $ pack "bar"
|
||||
, jsonScalar $ Encoded $ pack "baz"
|
||||
])
|
||||
]
|
||||
t <- hamletToText id $ unJson j
|
||||
|
||||
@ -1,6 +0,0 @@
|
||||
#!/bin/sh
|
||||
|
||||
for f in examples/*.*hs
|
||||
do
|
||||
ghc --make -Wall -Werror $f || exit
|
||||
done
|
||||
@ -1,30 +0,0 @@
|
||||
<!DOCTYPE html>
|
||||
<html>
|
||||
<head>
|
||||
<title>Factorials</title>
|
||||
<script src="http://ajax.googleapis.com/ajax/libs/jquery/1.3.2/jquery.min.js"></script>
|
||||
<script>
|
||||
$(function(){
|
||||
$("#num").parent().append("<span id='result'></span>");
|
||||
$("#submit").click(function() {
|
||||
$.getJSON($("#num").attr("value") + "/", function(o) {
|
||||
$("#result").text("fact(" + o.input + ") = " + o.result);
|
||||
});
|
||||
return false;
|
||||
});
|
||||
});
|
||||
</script>
|
||||
<style>
|
||||
#result {
|
||||
padding-left: 1em;
|
||||
color: #090;
|
||||
}
|
||||
</style>
|
||||
</head>
|
||||
<body>
|
||||
<form method="get" action="fact/">
|
||||
<p><label for="num">Number:</label> <input type="text" id="num" name="num"></p>
|
||||
<p><input id="submit" type="submit" value="Get the factorial!"></p>
|
||||
</form>
|
||||
</body>
|
||||
</html>
|
||||
@ -1,106 +0,0 @@
|
||||
FIXME documentation is out of date in a few places.
|
||||
|
||||
> {-# LANGUAGE QuasiQuotes #-}
|
||||
> {-# LANGUAGE TemplateHaskell #-}
|
||||
> {-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
I in general recommend type signatures for everything. However, I wanted
|
||||
to show in this example how it is possible to get away without the
|
||||
signatures.
|
||||
|
||||
> {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
|
||||
|
||||
There are only two imports: Yesod includes all of the code we need for creating
|
||||
a web application, while Network.Wai.Handler.SimpleServer allows us to test our
|
||||
application easily. A Yesod app can in general run on any WAI handler, so this
|
||||
application is easily convertible to CGI, FastCGI, or even run on the Happstack
|
||||
server.
|
||||
|
||||
> import Yesod
|
||||
> import Network.Wai.Handler.SimpleServer
|
||||
|
||||
The easiest way to start writing a Yesod app is to follow the Yesod typeclass.
|
||||
You define some data type which will contain all the specific settings and data
|
||||
you want in your application. This might include database connections,
|
||||
templates, etc. It's entirely up to you.
|
||||
|
||||
For our simple demonstration, we need no extra data, so we simply define Fact
|
||||
as:
|
||||
|
||||
> data Fact = Fact
|
||||
|
||||
Now we need to declare an instance of Yesod for Fact. The most important
|
||||
function to declare is handlers, which defines which functions deal with which
|
||||
resources (aka URLs).
|
||||
|
||||
You can declare the function however you want, but Yesod.Resource declares a
|
||||
convenient "resources" quasi-quoter which takes YAML content and generates the
|
||||
function for you. There is a lot of cool stuff to do with representations going
|
||||
on here, but this is not the appropriate place to discuss it.
|
||||
|
||||
|
||||
|
||||
The structure is very simply: top level key is a "resource pattern". A resource pattern is simply a bunch of slash-separated strings, called "resource pattern pieces". There are three special ways to start a piece:
|
||||
|
||||
* $: will take any string
|
||||
|
||||
* \#: will take any integer
|
||||
|
||||
* \*: will "slurp" up all the remaining pieces. Useful for something like
|
||||
/static/*filepath
|
||||
|
||||
Otherwise, the piece is treated as a literal string which must be matched.
|
||||
|
||||
|
||||
Now we have a mapping of verbs to handler functions. We could instead simply
|
||||
specify a single function which handles all verbs. (Note: a verb is just a
|
||||
request method.)
|
||||
|
||||
> $(mkYesod "Fact" [$parseRoutes|
|
||||
> / Index GET
|
||||
> /#num FactR GET
|
||||
> /fact FactRedirect GET
|
||||
> |])
|
||||
|
||||
> instance Yesod Fact where
|
||||
> approot _ = "http://localhost:3000"
|
||||
|
||||
This does what it looks like: serves a static HTML file.
|
||||
|
||||
> getIndex = sendFile TypeHtml "examples/fact.html" >> return ()
|
||||
|
||||
HtmlObject is a funny beast. Basically, it allows multiple representations of
|
||||
data, all with HTML entities escaped properly. These representations include:
|
||||
|
||||
* Simple HTML document (only recommended for testing).
|
||||
* JSON (great for Ajax)
|
||||
* Input to a HStringTemplate (great for no-Javascript fallback).
|
||||
|
||||
For simplicity here, we don't include a template, though it would be trivial to
|
||||
do so (see the hellotemplate example).
|
||||
|
||||
> getFactR :: Integer -> Handler y ChooseRep -- FIXME remove
|
||||
> getFactR _i = error "FIXME" {-simpleApplyLayout "Factorial result" $ cs
|
||||
> [ ("input", show i)
|
||||
> , ("result", show $ product [1..fromIntegral i :: Integer])
|
||||
> ]-}
|
||||
|
||||
I've decided to have a redirect instead of serving the some data in two
|
||||
locations. It fits in more properly with the RESTful principal of one name for
|
||||
one piece of data.
|
||||
|
||||
> getFactRedirect :: Handler y ()
|
||||
> getFactRedirect = do
|
||||
> res <- runFormPost $ catchFormError
|
||||
> $ checkInteger
|
||||
> $ required
|
||||
> $ input "num"
|
||||
> let i = either (const "1") show res
|
||||
> redirect RedirectPermanent $ "../" ++ i ++ "/"
|
||||
|
||||
You could replace this main to use any WAI handler you want. For production,
|
||||
you could use CGI, FastCGI or a more powerful server. Just check out Hackage
|
||||
for options (any package starting hack-handler- should suffice).
|
||||
|
||||
> main :: IO ()
|
||||
> main = putStrLn "Running..." >> toWaiApp Fact >>= run 3000
|
||||
@ -1,38 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
import Yesod
|
||||
import Network.Wai.Handler.SimpleServer
|
||||
|
||||
data Ham = Ham
|
||||
|
||||
mkYesod "Ham" [$parseRoutes|
|
||||
/ Homepage GET
|
||||
/#another Another GET
|
||||
|]
|
||||
|
||||
instance Yesod Ham where
|
||||
approot _ = "http://localhost:3000"
|
||||
|
||||
data NextLink = NextLink { nextLink :: HamRoutes }
|
||||
|
||||
template :: Monad m => NextLink -> Hamlet HamRoutes m ()
|
||||
template = [$hamlet|
|
||||
%a!href=@nextLink@ Next page
|
||||
|]
|
||||
|
||||
getHomepage :: Handler Ham RepHtml
|
||||
getHomepage = hamletToRepHtml $ template $ NextLink $ Another 1
|
||||
|
||||
getAnother :: Integer -> Handler Ham RepHtml
|
||||
getAnother i = hamletToRepHtml $ template $ NextLink next
|
||||
where
|
||||
next = case i of
|
||||
5 -> Homepage
|
||||
_ -> Another $ i + 1
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "Running..."
|
||||
toWaiApp Ham >>= run 3000
|
||||
@ -1,23 +0,0 @@
|
||||
\begin{code}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
import Yesod
|
||||
import Network.Wai.Handler.SimpleServer
|
||||
|
||||
data HelloWorld = HelloWorld
|
||||
|
||||
mkYesod "HelloWorld" [$parseRoutes|
|
||||
/ Home GET
|
||||
|]
|
||||
|
||||
instance Yesod HelloWorld where
|
||||
approot _ = "http://localhost:3000"
|
||||
|
||||
getHome :: Handler HelloWorld RepHtml
|
||||
getHome = simpleApplyLayout "Hello World" $ cs "Hello world!"
|
||||
|
||||
main :: IO ()
|
||||
main = putStrLn "Running..." >> toWaiApp HelloWorld >>= run 3000
|
||||
\end{code}
|
||||
@ -1,36 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
import Yesod
|
||||
import Network.Wai.Handler.SimpleServer
|
||||
|
||||
data I18N = I18N
|
||||
|
||||
mkYesod "I18N" [$parseRoutes|
|
||||
/ Homepage GET
|
||||
/set/$lang SetLang GET
|
||||
|]
|
||||
|
||||
instance Yesod I18N where
|
||||
approot _ = "http://localhost:3000"
|
||||
|
||||
getHomepage :: Handler y [(ContentType, Content)]
|
||||
getHomepage = do
|
||||
ls <- languages
|
||||
let hello = chooseHello ls
|
||||
return [(TypePlain, cs hello :: Content)]
|
||||
|
||||
chooseHello :: [Language] -> String
|
||||
chooseHello [] = "Hello"
|
||||
chooseHello ("he":_) = "שלום"
|
||||
chooseHello ("es":_) = "Hola"
|
||||
chooseHello (_:rest) = chooseHello rest
|
||||
|
||||
getSetLang :: String -> Handler y ()
|
||||
getSetLang lang = do
|
||||
addCookie 1 langKey lang
|
||||
redirect RedirectTemporary "/"
|
||||
|
||||
main :: IO ()
|
||||
main = putStrLn "Running..." >> toWaiApp I18N >>= run 3000
|
||||
@ -1,67 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
import Yesod
|
||||
import Data.Object.Yaml
|
||||
import Network.Wai.Handler.SimpleServer
|
||||
import Web.Encodings
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Object.String
|
||||
|
||||
data PY = PY
|
||||
|
||||
mkYesod "PY" [$parseRoutes|
|
||||
/ Homepage GET POST
|
||||
|]
|
||||
|
||||
instance Yesod PY where
|
||||
approot _ = "http://localhost:3000"
|
||||
|
||||
template :: Monad m => TempArgs url m -> Hamlet url m ()
|
||||
template = [$hamlet|
|
||||
!!!
|
||||
%html
|
||||
%head
|
||||
%meta!charset=utf-8
|
||||
%title Pretty YAML
|
||||
%body
|
||||
%form!method=post!action=.!enctype=multipart/form-data
|
||||
File name:
|
||||
%input!type=file!name=yaml
|
||||
%input!type=submit
|
||||
$if hasYaml
|
||||
%div ^yaml^
|
||||
|]
|
||||
|
||||
data TempArgs url m = TempArgs
|
||||
{ hasYaml :: Bool
|
||||
, yaml :: Hamlet url m ()
|
||||
}
|
||||
|
||||
getHomepage :: Handler PY RepHtml
|
||||
getHomepage = hamletToRepHtml
|
||||
$ template $ TempArgs False (return ())
|
||||
|
||||
--FIXMEpostHomepage :: Handler PY RepHtmlJson
|
||||
postHomepage :: Handler PY RepHtml
|
||||
postHomepage = do
|
||||
rr <- getRequest
|
||||
(_, files) <- liftIO $ reqRequestBody rr
|
||||
fi <- case lookup "yaml" files of
|
||||
Nothing -> invalidArgs [("yaml", "Missing input")]
|
||||
Just x -> return x
|
||||
so <- liftIO $ decode $ B.concat $ L.toChunks $ fileContent fi
|
||||
{- FIXME
|
||||
let ho' = fmap Text to
|
||||
templateHtmlJson "pretty-yaml" ho' $ \ho ->
|
||||
return . setHtmlAttrib "yaml" (Scalar $ cs ho :: HtmlObject)
|
||||
-}
|
||||
let ho = cs (so :: StringObject) :: HtmlObject
|
||||
hamletToRepHtml $ template $ TempArgs True (cs ho)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "Running..."
|
||||
toWaiApp PY >>= run 3000
|
||||
@ -1,16 +0,0 @@
|
||||
<!DOCTYPE html>
|
||||
<html>
|
||||
<head>
|
||||
<meta charset="utf-8">
|
||||
<title>Pretty YAML</title>
|
||||
</head>
|
||||
<body>
|
||||
<form method="post" action="." enctype="multipart/form-data">
|
||||
File name: <input type="file" name="yaml">
|
||||
<input type="submit">
|
||||
</form>
|
||||
$if(yaml)$
|
||||
<div>$yaml$</div>
|
||||
$endif$
|
||||
</body>
|
||||
</html>
|
||||
@ -1,3 +0,0 @@
|
||||
This is a more realistic template.
|
||||
foo: $foo$
|
||||
This is the default argument: $default$
|
||||
@ -1,25 +0,0 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in Hamlet
|
||||
|
||||
import Yesod
|
||||
import Yesod.Helpers.Static
|
||||
import Network.Wai.Handler.SimpleServer
|
||||
|
||||
data StaticExample = StaticExample
|
||||
|
||||
mkYesod "StaticExample" [$parseRoutes|
|
||||
/ Root StaticRoutes siteStatic getStaticSite
|
||||
|]
|
||||
|
||||
instance Yesod StaticExample where
|
||||
approot _ = "http://localhost:3000"
|
||||
|
||||
getStaticSite :: StaticExample -> Static
|
||||
getStaticSite _ = fileLookupDir "dist/doc/html/yesod"
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "Running..."
|
||||
toWaiApp StaticExample >>= run 3000
|
||||
@ -1,26 +0,0 @@
|
||||
<!DOCTYPE html>
|
||||
<html>
|
||||
<head>
|
||||
<meta charset="utf-8">
|
||||
<title>$title$</title>
|
||||
<style>
|
||||
body {
|
||||
background-color: #ffc;
|
||||
}
|
||||
|
||||
#wrapper {
|
||||
width: 600px;
|
||||
margin: 2em auto;
|
||||
background-color: #fefefe;
|
||||
border: 1px solid black;
|
||||
padding: 1em;
|
||||
font-family: sans-serif;
|
||||
}
|
||||
</style>
|
||||
</head>
|
||||
<body>
|
||||
<div id="wrapper">
|
||||
$content$
|
||||
</div>
|
||||
</body>
|
||||
</html>
|
||||
@ -1,27 +0,0 @@
|
||||
$layout(
|
||||
title={Category $name$};
|
||||
content={
|
||||
<ul id="breadcrumbs">
|
||||
$parents:{parent|
|
||||
<li><a href="../$parent.id$/">$parent.name$</a></li>
|
||||
}$
|
||||
</ul>
|
||||
<h1>$name$</h1>
|
||||
|
||||
<form method="post" action="?_method_override=put">New subcategory: <input type="text" name="catname"> <input type="submit" value="Create!"></form>
|
||||
<h2>Sub categories</h2>
|
||||
<ul>
|
||||
$cat.cats:{cat|
|
||||
<li><a href="../$cat.id$/">$cat.name$</a></li>
|
||||
}$
|
||||
</ul>
|
||||
|
||||
<form method="post" action="issues/?_method_override=put">New issue: <input type="text" name="issuename"> <input type="submit" value="Create!"></form>
|
||||
<h2>Issues</h2>
|
||||
<table>
|
||||
<thead><tr><th>Title</th><th>Status</th><th>Priority</th></tr></thead><tbody>
|
||||
$cat.issues:{issue|
|
||||
<tr><td><a href="../../issue/$issue.id$/">$issue.name$</a></td><td>$issue.status$</td><td>$issue.priority$</td></tr>
|
||||
}$
|
||||
</tbody></table>
|
||||
})$
|
||||
@ -1,37 +0,0 @@
|
||||
$layout(
|
||||
title={Issue $issue.name$ -- Category $cat.name$};
|
||||
content={
|
||||
<h1>$issue.name$</h1>
|
||||
<h2><a href="../../category/$cat.id$/">$cat.name$</a></h2>
|
||||
|
||||
$if(ident)$
|
||||
<form method="post" action="?_method_override=put">
|
||||
<h4>Add new message</h4>
|
||||
<table>
|
||||
<tr><td>Status (optional)</td><td><input type="text" name="status"></td></tr>
|
||||
<tr><td>Priority (optional)</td><td><input type="text" name="priority"></td></tr>
|
||||
<tr><td>Description</td><td><textarea style="width:500px;height:250px" name="text"></textarea></td></tr>
|
||||
<tr><td colspan="2"><input type="submit" value="Add message"></td></tr>
|
||||
<table>
|
||||
</form>
|
||||
$else$
|
||||
<form method="get" action="../../auth/openid/forward/"><h4>You must log in to add a message.</h4>
|
||||
OpenID: <input type="text" name="openid"> <input type="submit" value="Login">
|
||||
</form>
|
||||
$endif$
|
||||
|
||||
<h3>Messages</h3>
|
||||
$issue.messages:{message|
|
||||
<div class="message">
|
||||
<p>Author: $message.author$</p>
|
||||
<p>Created: $message.creation$</p>
|
||||
$if(message.status)$
|
||||
<p>Updated status: $message.status$</p>
|
||||
$endif$
|
||||
$if(message.priority)$
|
||||
<p>Updated priority: $message.priority$</p>
|
||||
$endif$
|
||||
<div>$message.text$</div>
|
||||
</div>
|
||||
}$
|
||||
})$
|
||||
@ -1,22 +0,0 @@
|
||||
<!DOCTYPE html>
|
||||
<html>
|
||||
<head>
|
||||
<title>$title$ -- Tweedle</title>
|
||||
<style>
|
||||
.message {
|
||||
border: 1px solid black;
|
||||
margin-bottom: 10px;
|
||||
padding: 10px;
|
||||
}
|
||||
.message p {
|
||||
margin: 0;
|
||||
}
|
||||
.message div {
|
||||
margin-top: 15px;
|
||||
}
|
||||
</style>
|
||||
</head>
|
||||
<body>
|
||||
$content$
|
||||
</body>
|
||||
</html>
|
||||
@ -1,410 +0,0 @@
|
||||
#!/usr/bin/env runhaskell
|
||||
|
||||
FIXME documentation out of date.
|
||||
|
||||
> {-# LANGUAGE QuasiQuotes #-}
|
||||
> {-# LANGUAGE TemplateHaskell #-}
|
||||
> {-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
While coming up on the first release of Yesod, I realized I needed a nice, comprehensive tutorial. I didn't want to do the typical blog example, since it's so trite. I considered doing a Reddit or Twitter clone (the former became a bit of a meme a few weeks ago), but then I needed to set up a bug tracker for some commercial projects I was working on, and I decided that it would be a great example program.
|
||||
|
||||
Before getting started, a quick word of warning: Yesod at this point really provides nothing in terms of data storage (aka, the model). There is wonderful integration with the data-object package, and the data-object-yaml package provides good serialization, but this is all very inefficient in practice. For simplicity, I've gone ahead and used this as the storage model; this should not be done for production code.
|
||||
|
||||
There's a lot of boilerplate code at the beginning that just has to do with object storage; if you'd like to skip it, just start reading from the main function.
|
||||
|
||||
Anyway, here's the import list.
|
||||
|
||||
> import Yesod
|
||||
> import Yesod.Helpers.Auth
|
||||
> import Data.Object.Yaml
|
||||
> import Data.Object.String
|
||||
> import Control.Concurrent
|
||||
> import qualified Safe.Failure as SF
|
||||
> import Data.Time
|
||||
> import Data.Attempt (Attempt, fromAttempt)
|
||||
> import Control.Arrow (second)
|
||||
> import qualified Network.Wai.Handler.SimpleServer
|
||||
> import Data.Monoid
|
||||
> import Data.Text (pack)
|
||||
> import Control.Applicative ((<$>), (<*>))
|
||||
> import Data.Maybe (fromMaybe)
|
||||
> import qualified Network.Wai as W
|
||||
|
||||
One of the goals of Yesod is to make it work with the compiler to help you program. Instead of configuration files, it uses typeclasses to both change default behavior and enable extra features. An example of the former is error pages, while an example of the latter is authentication.
|
||||
|
||||
To start with, we need a datatype to represent our program. We'll call this bug tracker "Tweedle", after Dr. Seuss's "Tweedle Beetle Battle" in "Fox in Socks" (my son absolutely loves this book). We'll be putting the complete state of the bug database in an MVar within this variable; in a production setting, you might instead put a database handle.
|
||||
|
||||
> data Tweedle = Tweedle Settings (MVar Category)
|
||||
|
||||
(For now, just ignore the TemplateGroup, its purpose becomes apparent later.)
|
||||
|
||||
This issue database is fully hierarchical: each category can contain subcategories and issues. This might be too much nesting for many uses, but it's what my project demanded.
|
||||
|
||||
Also, if I cared about efficiency here, a trie or map would probably be a better data structure. As stated above, it doesn't matter.
|
||||
|
||||
> data Category = Category
|
||||
> { subCats :: [Category]
|
||||
> , subIssues :: [Issue]
|
||||
> , categoryId :: Integer
|
||||
> , catName :: String
|
||||
> }
|
||||
|
||||
> data Issue = Issue
|
||||
> { issueName :: String
|
||||
> , issueMessages :: [Message]
|
||||
> , issueId :: Integer
|
||||
> }
|
||||
|
||||
Further simplifications: authors will just be represented by their OpenID URL.
|
||||
|
||||
> data Message = Message
|
||||
> { messageAuthor :: OpenId
|
||||
> , messageStatus :: Maybe String
|
||||
> , messagePriority :: Maybe String
|
||||
> , messageText :: String
|
||||
> , messageCreation :: UTCTime
|
||||
> }
|
||||
|
||||
> type OpenId = String
|
||||
|
||||
We need to be able to serialize this data to and from YAML files. You can consider all of the following code boilerplate.
|
||||
|
||||
> messageToSO :: Message -> StringObject
|
||||
> messageToSO m = Mapping $ map (second Scalar)
|
||||
> [ ("author", messageAuthor m)
|
||||
> , ("status", show $ messageStatus m)
|
||||
> , ("priority", show $ messagePriority m)
|
||||
> , ("text", messageText m)
|
||||
> , ("creation", show $ messageCreation m)
|
||||
> ]
|
||||
> messageFromSO :: StringObject -> Attempt Message
|
||||
> messageFromSO so = do
|
||||
> m <- fromMapping so
|
||||
> a <- lookupScalar "author" m
|
||||
> s <- lookupScalar "status" m >>= SF.read
|
||||
> p <- lookupScalar "priority" m >>= SF.read
|
||||
> t <- lookupScalar "text" m
|
||||
> c <- lookupScalar "creation" m >>= SF.read
|
||||
> return $ Message a s p t c
|
||||
> issueToSO :: Issue -> StringObject
|
||||
> issueToSO i = Mapping
|
||||
> [ ("name", Scalar $ issueName i)
|
||||
> , ("messages", Sequence $ map messageToSO $ issueMessages i)
|
||||
> , ("id", Scalar $ show $ issueId i)
|
||||
> ]
|
||||
> issueFromSO :: StringObject -> Attempt Issue
|
||||
> issueFromSO so = do
|
||||
> m <- fromMapping so
|
||||
> n <- lookupScalar "name" m
|
||||
> i <- lookupScalar "id" m >>= SF.read
|
||||
> ms <- lookupSequence "messages" m >>= mapM messageFromSO
|
||||
> return $ Issue n ms i
|
||||
> categoryToSO :: Category -> StringObject
|
||||
> categoryToSO c = Mapping
|
||||
> [ ("cats", Sequence $ map categoryToSO $ subCats c)
|
||||
> , ("issues", Sequence $ map issueToSO $ subIssues c)
|
||||
> , ("id", Scalar $ show $ categoryId c)
|
||||
> , ("name", Scalar $ catName c)
|
||||
> ]
|
||||
> categoryFromSO :: StringObject -> Attempt Category
|
||||
> categoryFromSO so = do
|
||||
> m <- fromMapping so
|
||||
> cats <- lookupSequence "cats" m >>= mapM categoryFromSO
|
||||
> issues <- lookupSequence "issues" m >>= mapM issueFromSO
|
||||
> i <- lookupScalar "id" m >>= SF.read
|
||||
> n <- lookupScalar "name" m
|
||||
> return $ Category cats issues i n
|
||||
|
||||
Well, that was a mouthful. You can safely ignore all of that: it has nothing to do with actual web programming.
|
||||
|
||||
Next is the Settings datatype. Normally I create a settings file so I can easily make changes between development and production systems without recompiling, but once again we are aiming for simplicity here.
|
||||
|
||||
> data Settings = Settings
|
||||
|
||||
Many web frameworks make the simplifying assumptions that "/" will be the path to the root of your application. In real life, this doesn't always happen. In Yesod, you must specify explicitly your application root and then create an instance of YesodApproot (see below). Again, the compiler will let you know this: once you use a feature that depends on knowing the approot, you'll get a compiler error if you haven't created the instance.
|
||||
|
||||
> { sApproot :: String
|
||||
> , issueFile :: FilePath
|
||||
|
||||
Yesod comes built in with support for HStringTemplate. You'll see later how this ties in with data-object (and in particular HtmlObject) to help avoid XSS attacks.
|
||||
|
||||
> , templatesDir :: FilePath
|
||||
> }
|
||||
|
||||
And now we'll hardcode the settings instead of loading from a file. I'll do it in the IO monad anyway, since that would be the normal function signature.
|
||||
|
||||
> loadSettings :: IO Settings
|
||||
> loadSettings = return $ Settings "http://localhost:3000/" "issues.yaml" "examples/tweedle-templates"
|
||||
|
||||
And now we need a function to load up our Tweedle data type.
|
||||
|
||||
> loadTweedle :: IO Tweedle
|
||||
> loadTweedle = do
|
||||
> settings <- loadSettings
|
||||
|
||||
Note that this will die unless an issues file is present. We could instead check for the file and create it if missing, but instead, just put the following into issues.yaml:
|
||||
|
||||
{cats: [], issues: [], id: 0, name: "Top Category"}
|
||||
|
||||
> issuesSO <- decodeFile $ issueFile settings
|
||||
> issues <- fromAttempt $ categoryFromSO issuesSO
|
||||
> missues <- newMVar issues
|
||||
> tg <- error "FIXME switch to hamlet" -- loadTemplateGroup $ templatesDir settings
|
||||
> return $ Tweedle settings missues tg
|
||||
|
||||
And now we're going to write our main function. Yesod is built on top of the Web Application Interface (wai package), so a Yesod application runs on a variety of backends. For our purposes, we're going to use the SimpleServer.
|
||||
|
||||
> main :: IO ()
|
||||
> main = do
|
||||
> putStrLn "Running at http://localhost:3000/"
|
||||
> tweedle <- loadTweedle
|
||||
> app <- toWaiApp tweedle
|
||||
> Network.Wai.Handler.SimpleServer.run 3000 app
|
||||
|
||||
Well, that was a *lot* of boilerplate code that had nothing to do with web programming. Now the real stuff begins. I would recommend trying to run the code up to now an see what happens. The compiler will complain that there is no instance of Yesod for Tweedle. This is what I meant by letting the compiler help us out. So now we've got to create the Yesod instance.
|
||||
|
||||
The Yesod typeclass includes many functions, most of which have default implementations. I'm not going to go through all of them here, please see the documentation.
|
||||
|
||||
The most important function is resources: this is where all of the URL mapping will occur. Yesod adheres to Restful principles very strongly. A "resource" is essentially a URL. Each resource should be unique; for example, do not create /user/5/ as well as /user/by-number/5/. In addition to resources, we also determine which function should handle your request based on the request method. In other words, a POST and a GET are completely different.
|
||||
|
||||
One of the middlewares that Yesod installs is called MethodOverride; please see the documentation there for more details, but essentially it allows us to work past a limitation in the form tag of HTML to use PUT and DELETE methods as well.
|
||||
|
||||
Instead of using regular expressions to handle the URL mapping, Yesod uses resource patterns. A resource is a set of tokens separated by slashes. Each of those tokens can be one of:
|
||||
|
||||
* A static string.
|
||||
* An integer variable (begins with #), which will match any integer.
|
||||
* A string varaible (begins with $), which will match any single value.
|
||||
* A "slurp" variable, which will match all of the remaining tokens. It must be the last token.
|
||||
|
||||
Yesod uses quasi quotation to make specifying the resource pattern simple and safe: your entire set of patterns is checked at compile time to see if you have overlapping rules.
|
||||
|
||||
> mkYesod "Tweedle" [$parseRoutes|
|
||||
|
||||
Now we need to figure out all of the resources available in our application. We'll need a homepage:
|
||||
|
||||
> / Homepage GET
|
||||
|
||||
We will also need to allow authentication. We use the slurp pattern here and accept all request methods. The authHandler method (in the Yesod.Helpers.Auth module) will handle everything itself.
|
||||
|
||||
> /auth/* AuthHandler
|
||||
|
||||
We're going to refer to categories and issues by their unique numerical id. We're also going to make this system append only: there is no way to change the history.
|
||||
|
||||
> /category/#id CategoryH GET PUT
|
||||
> /category/#id/issues Issues PUT
|
||||
> /issue/#id IssueH GET PUT
|
||||
> |]
|
||||
|
||||
So if you make a PUT request to "/category/5", you will be creating a subcategory of category 5. "GET /issue/27/" will display details on issue 27. This is all we need.
|
||||
|
||||
If you try to compile the code until this point, the compiler will tell you that you have to define all of the above-mentioned functions. We'll do that in a second; for now, if you'd like to see the rest of the error messages, uncomment this next block of code.
|
||||
|
||||
> {-
|
||||
> homepageH = return ()
|
||||
> categoryDetailsH _ = return ()
|
||||
> createCategoryH _ = return ()
|
||||
> createIssueH _ = return ()
|
||||
> issueDetailsH _ = return ()
|
||||
> addMessageH _ = return ()
|
||||
> -}
|
||||
|
||||
Now the compiler is telling us that there's no instance of YesodAuth for Tweedle. YesodAuth- as you might imagine- keeps settings on authentication. We're going to go ahead a create an instance now. The default settings work if you set up authHandler for "/auth/*" (which we did) and are using openid (which we are). So all we need to do is:
|
||||
|
||||
> instance YesodAuth Tweedle
|
||||
|
||||
Running that tells us that we're missing a YesodApproot instance as well. That's easy enough to fix:
|
||||
|
||||
> instance Yesod Tweedle where
|
||||
> approot (Tweedle settings _ _) = sApproot settings
|
||||
|
||||
Congratulations, you have a working web application! Gratned, it doesn't actually do much yet, but you *can* use it to log in via openid. Just go to http://localhost:3000/auth/openid/.
|
||||
|
||||
Now it's time to implement the real code here. We'll start with the homepage. For this program, I just want the homepage to redirect to the main category (which will be category 0). So let's create that redirect:
|
||||
|
||||
> getHomepage :: Handler Tweedle ()
|
||||
> getHomepage = do
|
||||
> ar <- getApproot
|
||||
> redirect RedirectPermanent $ ar ++ "category/0/"
|
||||
|
||||
Simple enough. Notice that we used the getApproot function; if we wanted, we could have just assumed the approot was "/", but this is more robust.
|
||||
|
||||
Now the category details function. We're just going to have two lists: subcategories and direct subissues. Each one will have a name and numerical ID.
|
||||
|
||||
But here's a very nice feature of Yesod: We're going to have multiple representations of this data. The main one people will use is the HTML representation. However, we're also going to provide a JSON representation. This will make it very simple to write clients or to AJAXify this application in the future.
|
||||
|
||||
> getCategoryH :: Integer -> Handler Tweedle RepHtmlJson
|
||||
|
||||
That function signature tells us a lot: the parameter is the category ID, and we'll be returning something that has both an HTML and JSON representation.
|
||||
|
||||
> getCategoryH catId = do
|
||||
|
||||
getYesod returns our Tweedle data type. Remember, we wrapped it in an MVar; since this is a read-only operation, will unwrap the MVar immediately.
|
||||
|
||||
> Tweedle _ mvarTopCat _ <- getYesod
|
||||
> topcat <- liftIO $ readMVar mvarTopCat
|
||||
|
||||
Next we need to find the requested category. You'll see the (boilerplate) function below. If the category doesn't exist, we want to return a 404 response page. So:
|
||||
|
||||
> (parents, cat) <- maybe notFound return $ findCat catId [] topcat
|
||||
|
||||
Now we want to convert the category into an HtmlObject. By doing so, we will get automatic HTML entity encoding; in other words, no XSS attacks.
|
||||
|
||||
> let catHelper (Category _ _ cid name) = Mapping
|
||||
> [ ("name", Scalar $ Text $ pack name)
|
||||
> , ("id", Scalar $ Text $ pack $ show cid)
|
||||
> ]
|
||||
> let statusHelper = fromMaybe "No status set"
|
||||
> . getLast . mconcat . map (Last . messageStatus)
|
||||
> let priorityHelper = fromMaybe "No priority set"
|
||||
> . getLast . mconcat . map (Last . messagePriority)
|
||||
> let issueHelper (Issue name messages iid) = Mapping
|
||||
> [ ("name", Scalar $ Text $ pack name)
|
||||
> , ("id", Scalar $ Text $ pack $ show iid)
|
||||
> , ("status", Scalar $ Text $ pack $ statusHelper messages)
|
||||
> , ("priority", Scalar $ Text $ pack $ priorityHelper messages)
|
||||
> ]
|
||||
> let ho = Mapping
|
||||
> [ ("cats", Sequence $ map catHelper $ subCats cat)
|
||||
> , ("issues", Sequence $ map issueHelper $ subIssues cat)
|
||||
> ]
|
||||
|
||||
And now we'll use a String Template to display the whole thing.
|
||||
|
||||
> templateHtmlJson "category-details" ho $ \_ -> return
|
||||
> . setHtmlAttrib "cat" ho
|
||||
> . setHtmlAttrib "name" (catName cat)
|
||||
> . setHtmlAttrib "parents" (Sequence $ map catHelper parents)
|
||||
|
||||
> findCat :: Integer -> [Category] -> Category -> Maybe ([Category], Category)
|
||||
> findCat i parents c@(Category cats _ i' _)
|
||||
> | i == i' = Just (parents, c)
|
||||
> | otherwise = getFirst $ mconcat $ map (First . findCat i (parents ++ [c])) cats
|
||||
|
||||
Now we get a new missing instance: YesodTemplate. As you can imagine, this is because of calling the templateHtmlJson function. This is easily enough solved (and explains why we needed TemplateGroup as part of Tweedle).
|
||||
|
||||
> instance YesodTemplate Tweedle where
|
||||
> getTemplateGroup (Tweedle _ _ tg) = tg
|
||||
|
||||
Now we actually get some output! I'm not going to cover the syntax of string templates here, but you should read the files in the examples/tweedle-templates directory.
|
||||
|
||||
Next, we need to implement createCategoryH. There are two parts to this process: parsing the form submission, and then modifying the database. Pay attention to the former, but you can ignore the latter if you wish. Also, this code does not do much for error checking, as that would needlessly complicate matters.
|
||||
|
||||
> putCategoryH :: Integer -> Handler Tweedle ()
|
||||
> putCategoryH parentid = do
|
||||
|
||||
Yesod uses a formlets-style interface for parsing submissions. This following line says we want a parameter named catname, which precisely one value (required) and that value must have a non-zero length (notEmpty).
|
||||
|
||||
> catname <- runFormPost $ notEmpty $ required $ input "catname"
|
||||
> newid <- modifyDB $ createCategory parentid catname
|
||||
> ar <- getApproot
|
||||
> redirect RedirectPermanent $ ar ++ "category/" ++ show newid ++ "/"
|
||||
|
||||
And here's the database modification code we need. Once again, this is not web-specific.
|
||||
|
||||
> modifyDB :: (Category -> (Category, x)) -> Handler Tweedle x
|
||||
> modifyDB f = do
|
||||
> Tweedle settings mcat _ <- getYesod
|
||||
> liftIO $ modifyMVar mcat $ \cat -> do
|
||||
> let (cat', x) = f cat
|
||||
> encodeFile (issueFile settings) $ categoryToSO cat'
|
||||
> return (cat', x)
|
||||
|
||||
> createCategory :: Integer -> String -> Category -> (Category, Integer)
|
||||
> createCategory parentid catname topcat =
|
||||
> let newid = highCatId topcat + 1
|
||||
> topcat' = addChild parentid (Category [] [] newid catname) topcat
|
||||
> in (topcat', newid)
|
||||
> where
|
||||
> highCatId (Category cats _ i _) = maximum $ i : map highCatId cats
|
||||
> addChild i' newcat (Category cats issues i name)
|
||||
> | i' /= i = Category (map (addChild i' newcat) cats) issues i name
|
||||
> | otherwise = Category (cats ++ [newcat]) issues i name
|
||||
|
||||
Next is creating an issue. This is almost identical to creating a category.
|
||||
|
||||
> putIssues :: Integer -> Handler Tweedle ()
|
||||
> putIssues catid = do
|
||||
> issuename <- runFormPost $ notEmpty $ required $ input "issuename"
|
||||
> newid <- modifyDB $ createIssue catid issuename
|
||||
> ar <- getApproot
|
||||
> redirect RedirectPermanent $ ar ++ "issue/" ++ show newid ++ "/"
|
||||
|
||||
> createIssue :: Integer -> String -> Category -> (Category, Integer)
|
||||
> createIssue catid issuename topcat =
|
||||
> let newid = highIssueId topcat + 1
|
||||
> topcat' = addIssue catid (Issue issuename [] newid) topcat
|
||||
> in (topcat', newid)
|
||||
> where
|
||||
> highIssueId (Category cats issues _ _) =
|
||||
> maximum $ 0 : (map issueId issues) ++ map highIssueId cats
|
||||
> addIssue i' newissue (Category cats issues i name)
|
||||
> | i' /= i = Category (map (addIssue i' newissue) cats) issues i name
|
||||
> | otherwise = Category cats (issues ++ [newissue]) i name
|
||||
|
||||
Two functions to go. Now we want to show details of issues. This isn't too different from categoryDetailsH above, except for one feature: we need to know if a user is logged in. If they are logged in, we'll show an "add message" box; otherwise, we'll show a login box. Once again, we're getting the JSON representation easily.
|
||||
|
||||
> getIssueH :: Integer -> Handler Tweedle RepHtmlJson
|
||||
> getIssueH iid = do
|
||||
> Tweedle _ mvarTopCat _ <- getYesod
|
||||
> topcat <- liftIO $ readMVar mvarTopCat
|
||||
> (cat, issue) <- maybe notFound return $ findIssue iid topcat
|
||||
> let messageHelper m = Mapping $ map (second $ Scalar . Text . pack)
|
||||
> $ (maybe id (\x -> (:) ("status", x)) $ messageStatus m)
|
||||
> $ (maybe id (\x -> (:) ("priority", x)) $ messagePriority m)
|
||||
> [ ("author", messageAuthor m)
|
||||
> , ("text", messageText m)
|
||||
> , ("creation", show $ messageCreation m)
|
||||
> ]
|
||||
> let ho = Mapping
|
||||
> [ ("name", Scalar $ Text $ pack $ issueName issue)
|
||||
> , ("messages", Sequence $ map messageHelper $ issueMessages issue)
|
||||
> ]
|
||||
|
||||
Now we determine is the user is logged in via the maybeIdentifier function. Later on, we'll see how we can force a user to be logged in using authIdentifier.
|
||||
|
||||
> ident <- maybeIdentifier
|
||||
|
||||
> templateHtmlJson "issue-details" ho $ \_ -> return
|
||||
> . setHtmlAttrib "issue" ho
|
||||
> . maybe id (setHtmlAttrib "ident") ident
|
||||
> . setHtmlAttrib "cat" (Mapping
|
||||
> [ ("name", Scalar $ Text $ pack $ catName cat)
|
||||
> , ("id", Scalar $ Text $ pack $ show $ categoryId cat)
|
||||
> ])
|
||||
|
||||
And now the supporting model code. This function returns the requested Issue along with the containing category.
|
||||
|
||||
> findIssue :: Integer -> Category -> Maybe (Category, Issue)
|
||||
> findIssue iid c@(Category cats issues _ _) =
|
||||
> case filter (\issue -> issueId issue == iid) issues of
|
||||
> [] -> getFirst $ mconcat $ map (First . findIssue iid) cats
|
||||
> (issue:_) -> Just (c, issue)
|
||||
|
||||
Cool, just one function left! This should probably all make sense by now. Notice, however, the use of authIdentifier: if the user is not logged in, they will be redirected to the login page automatically.
|
||||
|
||||
> putIssueH :: Integer -> Handler Tweedle ()
|
||||
> putIssueH issueid = do
|
||||
> ident <- authIdentifier
|
||||
> (status, priority, text) <- runFormPost $
|
||||
> (,,)
|
||||
> <$> optional (input "status")
|
||||
> <*> optional (input "priority")
|
||||
> <*> required (input "text")
|
||||
> now <- liftIO getCurrentTime
|
||||
> let message = Message ident status priority text now
|
||||
> modifyDB $ addMessage issueid message
|
||||
> ar <- getApproot
|
||||
> redirect RedirectPermanent $ ar ++ "issue/" ++ show issueid ++ "/"
|
||||
|
||||
> addMessage :: Integer -> Message -> Category -> (Category, ())
|
||||
> addMessage issueid message (Category cats issues catid catname) =
|
||||
> (Category (map (fst . addMessage issueid message) cats) (map go issues) catid catname, ())
|
||||
> where
|
||||
> go (Issue name messages iid)
|
||||
> | iid == issueid = Issue name (messages ++ [message]) iid
|
||||
> | otherwise = Issue name messages iid
|
||||
|
||||
> handleAuthHandler :: [String] -> Handler Tweedle ChooseRep
|
||||
> handleAuthHandler pieces = do
|
||||
> m <- W.requestMethod `fmap` waiRequest
|
||||
> authHandler m pieces
|
||||
@ -1,7 +1,5 @@
|
||||
import Test.Framework (defaultMain)
|
||||
|
||||
import qualified Yesod.Response
|
||||
import qualified Yesod.Request
|
||||
-- FIXME import qualified Test.Errors
|
||||
-- FIXME import qualified Test.QuasiResource
|
||||
import qualified Web.Mime
|
||||
@ -9,10 +7,9 @@ import qualified Yesod.Json
|
||||
|
||||
main :: IO ()
|
||||
main = defaultMain
|
||||
[ Yesod.Response.testSuite
|
||||
, Yesod.Request.testSuite
|
||||
[
|
||||
Web.Mime.testSuite
|
||||
, Yesod.Json.testSuite
|
||||
-- FIXME , Test.Errors.testSuite
|
||||
-- FIXME, Test.QuasiResource.testSuite
|
||||
, Web.Mime.testSuite
|
||||
, Yesod.Json.testSuite
|
||||
]
|
||||
|
||||
65
yesod.cabal
65
yesod.cabal
@ -25,19 +25,7 @@ flag buildtests
|
||||
description: Build the executable to run unit tests
|
||||
default: False
|
||||
|
||||
flag buildsamples
|
||||
description: Build the executable sample applications.
|
||||
default: False
|
||||
|
||||
flag nolib
|
||||
description: Skip building of the library.
|
||||
default: False
|
||||
|
||||
library
|
||||
if flag(nolib)
|
||||
Buildable: False
|
||||
else
|
||||
Buildable: True
|
||||
build-depends: base >= 4 && < 5,
|
||||
time >= 1.1.3 && < 1.2,
|
||||
wai >= 0.0.1 && < 0.3,
|
||||
@ -94,57 +82,14 @@ executable runtests
|
||||
QuickCheck >= 2 && < 3
|
||||
else
|
||||
Buildable: False
|
||||
if flag(transformers_02)
|
||||
build-depends: transformers >= 0.2 && < 0.3
|
||||
CPP-OPTIONS: -DTRANSFORMERS_02
|
||||
else
|
||||
build-depends: transformers >= 0.1 && < 0.2
|
||||
ghc-options: -Wall
|
||||
main-is: runtests.hs
|
||||
|
||||
executable helloworld
|
||||
if flag(buildsamples)
|
||||
Buildable: True
|
||||
else
|
||||
Buildable: False
|
||||
ghc-options: -Wall
|
||||
main-is: examples/helloworld.lhs
|
||||
|
||||
executable hamlet
|
||||
if flag(buildsamples)
|
||||
Buildable: True
|
||||
else
|
||||
Buildable: False
|
||||
ghc-options: -Wall
|
||||
main-is: examples/hamlet.hs
|
||||
|
||||
executable fact
|
||||
if flag(buildsamples)
|
||||
Buildable: True
|
||||
else
|
||||
Buildable: False
|
||||
ghc-options: -Wall
|
||||
main-is: examples/fact.lhs
|
||||
|
||||
executable i18n
|
||||
if flag(buildsamples)
|
||||
Buildable: True
|
||||
else
|
||||
Buildable: False
|
||||
ghc-options: -Wall
|
||||
main-is: examples/i18n.hs
|
||||
|
||||
executable pretty-yaml
|
||||
if flag(buildsamples)
|
||||
Buildable: True
|
||||
else
|
||||
Buildable: False
|
||||
ghc-options: -Wall
|
||||
main-is: examples/pretty-yaml.hs
|
||||
|
||||
executable tweedle
|
||||
if flag(buildsamples)
|
||||
Buildable: True
|
||||
else
|
||||
Buildable: False
|
||||
ghc-options: -Wall
|
||||
main-is: examples/tweedle.lhs
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: git://github.com/snoyberg/yesod.git
|
||||
|
||||
Loading…
Reference in New Issue
Block a user