yesod (empty) → 0.0.0
raw patch · 33 files changed
+3541/−0 lines, 33 filesdep +HStringTemplatedep +HUnitdep +QuickChecksetup-changed
Dependencies added: HStringTemplate, HUnit, QuickCheck, attempt, authenticate, base, bytestring, control-monad-attempt, convertible-text, data-object, data-object-json, data-object-yaml, directory, failure, file-embed, old-locale, predicates, safe-failure, split, syb, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, transformers, wai, wai-extra, web-encodings
Files
- CLI/skel/App.hs +70/−0
- CLI/skel/LICENSE +25/−0
- CLI/skel/settings.yaml +5/−0
- CLI/skel/static/style.css +10/−0
- CLI/skel/templates/homepage.st +7/−0
- CLI/skel/templates/layout.st +11/−0
- CLI/skel/webapp.cabal +21/−0
- CLI/yesod.hs +76/−0
- Data/Object/Html.hs +252/−0
- LICENSE +25/−0
- Setup.lhs +11/−0
- Web/Mime.hs +110/−0
- Yesod.hs +50/−0
- Yesod/Definitions.hs +68/−0
- Yesod/Form.hs +131/−0
- Yesod/Handler.hs +171/−0
- Yesod/Helpers/AtomFeed.hs +77/−0
- Yesod/Helpers/Auth.hs +260/−0
- Yesod/Helpers/Sitemap.hs +86/−0
- Yesod/Helpers/Static.hs +64/−0
- Yesod/Request.hs +151/−0
- Yesod/Resource.hs +532/−0
- Yesod/Response.hs +252/−0
- Yesod/Template.hs +113/−0
- Yesod/Yesod.hs +160/−0
- examples/fact.lhs +104/−0
- examples/hellotemplate.lhs +33/−0
- examples/helloworld.lhs +19/−0
- examples/i18n.hs +33/−0
- examples/pretty-yaml.hs +38/−0
- examples/tweedle.lhs +407/−0
- runtests.hs +20/−0
- yesod.cabal +149/−0
+ CLI/skel/App.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE QuasiQuotes #-}+import Yesod+import Yesod.Helpers.Static+import qualified Data.Object.Yaml+import qualified Safe.Failure++data $Datatype$ = $Datatype$+ { settings :: Settings+ , templateGroup :: TemplateGroup+ }++data Settings = Settings+ { sApproot :: String+ , staticRoot :: String+ , staticDir :: String+ , templateDir :: String+ , portNumber :: Int+ }++settingsFile :: FilePath+settingsFile = "settings.yaml"++loadSettings :: IO Settings+loadSettings = do+ m <- Data.Object.Yaml.decodeFile settingsFile >>= fromMapping+ ar <- lookupScalar "approot" m+ sr <- lookupScalar "static-root" m+ sd <- lookupScalar "static-dir" m+ td <- lookupScalar "template-dir" m+ pn <- lookupScalar "port" m >>= Safe.Failure.read+ return \$ Settings ar sr sd td pn++load$Datatype$ :: IO $Datatype$+load$Datatype$ = do+ s <- loadSettings+ tg <- loadTemplateGroup \$ templateDir s+ return \$ $Datatype$ s tg++main :: IO ()+main = do+ datatype <- load$Datatype$+ app <- toWaiApp datatype+ basicHandler (portNumber \$ settings datatype) app++instance Yesod $Datatype$ where+ resources = [\$mkResources|+/:+ GET: homepageH+/static/*: serveStatic'+|]+ applyLayout = defaultApplyLayout++instance YesodApproot $Datatype$ where+ approot = sApproot . settings++instance YesodTemplate $Datatype$ where+ getTemplateGroup = templateGroup+ defaultTemplateAttribs y _ = return+ . setHtmlAttrib "approot" (approot y)+ . setHtmlAttrib "staticroot" (staticRoot \$ settings y)++homepageH :: Handler $Datatype$ RepHtml+homepageH = templateHtml "homepage" return++serveStatic' :: Method -> [String]+ -> Handler $Datatype$ [(ContentType, Content)]+serveStatic' method pieces = do+ y <- getYesod+ let sd = staticDir \$ settings y+ serveStatic (fileLookupDir sd) method pieces
+ CLI/skel/LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright $year$, $author$. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ CLI/skel/settings.yaml view
@@ -0,0 +1,5 @@+approot: http://localhost:3000/+static-root: http://localhost:3000/static/+static-dir: static+template-dir: templates+port: 3000
+ CLI/skel/static/style.css view
@@ -0,0 +1,10 @@+html {+ background: #ccc;+}+body {+ width: 760px;+ margin: 10px auto;+ padding: 10px;+ border: 1px solid #333;+ background: #fff;+}
+ CLI/skel/templates/homepage.st view
@@ -0,0 +1,7 @@+\$layout(+ title={Homepage};+ content={+ <h1>Homepage</h1>+ <p>You probably want to put your own content here.</p>+ }+)\$
+ CLI/skel/templates/layout.st view
@@ -0,0 +1,11 @@+<!DOCTYPE html>+<html>+ <head>+ <title>\$title\$</title>+ <link rel="stylesheet" href="\$staticroot\$style.css">+ \$extrahead\$+ </head>+ <body>+ \$content\$+ </body>+</html>
+ CLI/skel/webapp.cabal view
@@ -0,0 +1,21 @@+name: $project$+version: 0.0.0+license: BSD3+license-file: LICENSE+author: $author$ $email$+maintainer: $author$ $email$+synopsis: A web application based on Yesod.+description: The default web application. You might want to change this.+category: Web+stability: Stable+cabal-version: >= 1.2+build-type: Simple+homepage: $homepage$++executable $project$+ build-depends: base >= 4 && < 5,+ yesod >= 0.0.0 && < 0.1,+ safe-failure >= 0.4.0 && < 0.5,+ data-object-yaml >= 0.2.0.1 && < 0.3+ main-is: $Datatype$.hs+ ghc-options: -Wall
+ CLI/yesod.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE TemplateHaskell #-}+import Data.FileEmbed+import Text.StringTemplate+import Data.ByteString.Char8 (ByteString, unpack)+import System.Directory+import System.Environment+import System.IO+import Data.Char++skel :: [(FilePath, ByteString)]+skel = $(embedDir "CLI/skel")++yesodInit :: FilePath -> [(String, String)] -> IO ()+yesodInit topDir a = do+ mapM_ (\x -> createDirectoryIfMissing True $ topDir ++ x)+ ["static", "templates"]+ mapM_ go skel+ where+ go (fp, bs) = do+ let temp = newSTMP $ unpack bs+ writeFile (topDir ++ fp) $ toString $ setManyAttrib a temp++main :: IO ()+main = do+ args <- getArgs+ case args of+ ["init"] -> yesodInit'+ _ -> usage++usage :: IO ()+usage = putStrLn "Currently, the only support operation is \"init\"."++prompt :: String -> (String -> Bool) -> IO String+prompt s t = do+ putStr s+ hFlush stdout+ x <- getLine+ if t x+ then return x+ else do+ putStrLn "That was not valid input."+ prompt s t++yesodInit' :: IO ()+yesodInit' = do+ putStrLn "Let's get started created a Yesod web application."+ dest <-+ prompt+ "In which directory would you like to put the application? "+ (not . null)+ dt <-+ prompt+ "Give a data type name (first letter capital): "+ (\x -> not (null x) && isUpper (head x))+ pr <- prompt+ "Name of project (cabal file): "+ (not . null)+ au <- prompt+ "Author (cabal file): "+ (not . null)+ em <- prompt+ "Author email (cabal file): "+ (not . null)+ ho <- prompt+ "Homepage (cabal file): "+ (not . null)+ yesodInit (dest ++ "/")+ [ ("Datatype", dt)+ , ("project", pr)+ , ("author", au)+ , ("email", em)+ , ("homepage", ho)+ ]+ renameFile (dest ++ "/webapp.cabal") (dest ++ "/" ++ pr ++ ".cabal")+ renameFile (dest ++ "/App.hs") (dest ++ "/" ++ dt ++ ".hs")+ putStrLn "Your project has been initialized."
+ Data/Object/Html.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+-- | An 'Html' data type and associated 'ConvertSuccess' instances. This has+-- useful conversions in web development:+--+-- * Automatic generation of simple HTML documents from 'HtmlObject' (mostly+-- useful for testing, you would never want to actually show them to an end+-- user).+--+-- * Converts to JSON, which gives fully HTML escaped JSON. Very nice for Ajax.+--+-- * Can be used with HStringTemplate.+module Data.Object.Html+ ( -- * Data type+ Html (..)+ , HtmlDoc (..)+ , HtmlFragment (..)+ , HtmlObject+ -- * XML helpers+ , XmlDoc (..)+ , cdata+ -- * Standard 'Object' functions+ , toHtmlObject+ , fromHtmlObject+ -- * Re-export+ , module Data.Object+#if TEST+ , testSuite+#endif+ ) where++import Data.Generics+import Data.Object.Text+import Data.Object.String+import Data.Object.Json+import qualified Data.Text.Lazy as TL+import qualified Data.Text as TS+import Web.Encodings+import Text.StringTemplate.Classes+import Control.Arrow (second)+import Data.Attempt+import Data.Object++#if TEST+import Test.Framework (testGroup, Test)+import Test.Framework.Providers.HUnit+import Test.HUnit hiding (Test)+import Text.StringTemplate+#endif++-- | A single piece of HTML code.+data Html =+ Html TS.Text -- ^ Already encoded HTML.+ | Text TS.Text -- ^ Text which should be HTML escaped.+ | Tag String [(String, String)] Html -- ^ Tag which needs a closing tag.+ | EmptyTag String [(String, String)] -- ^ Tag without a closing tag.+ | HtmlList [Html]+ deriving (Eq, Show, Typeable)++-- | A full HTML document.+newtype HtmlDoc = HtmlDoc { unHtmlDoc :: Text }++type HtmlObject = Object String Html++instance ConvertSuccess Html HtmlObject where+ convertSuccess = Scalar+instance ConvertSuccess [Html] HtmlObject where+ convertSuccess = Sequence . map cs+instance ConvertSuccess [HtmlObject] HtmlObject where+ convertSuccess = Sequence+instance ConvertSuccess [(String, HtmlObject)] HtmlObject where+ convertSuccess = Mapping+instance ConvertSuccess [(String, Html)] HtmlObject where+ convertSuccess = Mapping . map (second cs)+instance ConvertSuccess StringObject HtmlObject where+ convertSuccess = mapKeysValues cs cs++toHtmlObject :: ConvertSuccess x HtmlObject => x -> HtmlObject+toHtmlObject = cs++fromHtmlObject :: ConvertAttempt HtmlObject x => HtmlObject -> Attempt x+fromHtmlObject = ca++instance ConvertSuccess String Html where+ convertSuccess = Text . cs+instance ConvertSuccess TS.Text Html where+ convertSuccess = Text+instance ConvertSuccess Text Html where+ convertSuccess = Text . cs++instance ConvertSuccess String HtmlObject where+ convertSuccess = Scalar . cs+instance ConvertSuccess Text HtmlObject where+ convertSuccess = Scalar . cs+instance ConvertSuccess TS.Text HtmlObject where+ convertSuccess = Scalar . cs+instance ConvertSuccess [String] HtmlObject where+ convertSuccess = Sequence . map cs+instance ConvertSuccess [Text] HtmlObject where+ convertSuccess = Sequence . map cs+instance ConvertSuccess [TS.Text] HtmlObject where+ convertSuccess = Sequence . map cs+instance ConvertSuccess [(String, String)] HtmlObject where+ convertSuccess = omTO+instance ConvertSuccess [(Text, Text)] HtmlObject where+ convertSuccess = omTO+instance ConvertSuccess [(TS.Text, TS.Text)] HtmlObject where+ convertSuccess = omTO++showAttribs :: [(String, String)] -> String -> String+showAttribs pairs rest = foldr (($) . helper) rest pairs where+ helper :: (String, String) -> String -> String+ helper (k, v) rest' =+ ' ' : encodeHtml k+ ++ '=' : '"' : encodeHtml v+ ++ '"' : rest'++htmlToText :: Bool -- ^ True to close empty tags like XML, False like HTML+ -> Html+ -> ([TS.Text] -> [TS.Text])+htmlToText _ (Html t) = (:) t+htmlToText _ (Text t) = (:) $ encodeHtml t+htmlToText xml (Tag n as content) = \rest ->+ cs ('<' : n)+ : cs (showAttribs as ">")+ : htmlToText xml content+ ( cs ('<' : '/' : n)+ : cs ">"+ : rest)+htmlToText xml (EmptyTag n as) = \rest ->+ cs ('<' : n )+ : cs (showAttribs as (if xml then "/>" else ">"))+ : rest+htmlToText xml (HtmlList l) = flip (foldr ($)) (map (htmlToText xml) l)++newtype HtmlFragment = HtmlFragment { unHtmlFragment :: Text }+instance ConvertSuccess Html HtmlFragment where+ convertSuccess h = HtmlFragment . TL.fromChunks . htmlToText False h $ []+instance ConvertSuccess HtmlFragment Html where+ convertSuccess = HtmlList . map Html . TL.toChunks . unHtmlFragment+-- | Not fully typesafe. You must make sure that when converting to this, the+-- 'Html' starts with a tag.+newtype XmlDoc = XmlDoc { unXmlDoc :: Text }+instance ConvertSuccess Html XmlDoc where+ convertSuccess h = XmlDoc $ TL.fromChunks $+ cs "<?xml version='1.0' encoding='utf-8' ?>\n"+ : htmlToText True h []++-- | Wrap an 'Html' in CDATA for XML output.+cdata :: Html -> Html+cdata h = HtmlList+ [ Html $ cs "<![CDATA["+ , h+ , Html $ cs "]]>"+ ]++instance ConvertSuccess (Html, Html) HtmlDoc where+ convertSuccess (h, b) = HtmlDoc $ TL.fromChunks $+ cs "<!DOCTYPE html>\n"+ : htmlToText False (Tag "html" [] $ HtmlList+ [ Tag "head" [] h+ , Tag "body" [] b+ ]+ ) []+instance ConvertSuccess (Html, HtmlObject) HtmlDoc where+ convertSuccess (x, y) = cs (x, cs y :: Html)+instance ConvertSuccess (Html, HtmlObject) JsonDoc where+ convertSuccess (_, y) = cs y++instance ConvertSuccess HtmlObject Html where+ convertSuccess (Scalar h) = h+ convertSuccess (Sequence hs) = Tag "ul" [] $ HtmlList $ map addLi hs+ where+ addLi = Tag "li" [] . cs+ convertSuccess (Mapping pairs) =+ Tag "dl" [] $ HtmlList $ concatMap addDtDd pairs where+ addDtDd (k, v) =+ [ Tag "dt" [] $ Text $ cs k+ , Tag "dd" [] $ cs v+ ]++instance ConvertSuccess Html JsonScalar where+ convertSuccess = cs . unHtmlFragment . cs+instance ConvertAttempt Html JsonScalar where+ convertAttempt = return . cs++instance ConvertSuccess HtmlObject JsonObject where+ convertSuccess = mapKeysValues convertSuccess convertSuccess+instance ConvertAttempt HtmlObject JsonObject where+ convertAttempt = return . cs++instance ConvertSuccess HtmlObject JsonDoc where+ convertSuccess = cs . (cs :: HtmlObject -> JsonObject)+instance ConvertAttempt HtmlObject JsonDoc where+ convertAttempt = return . cs++instance ToSElem HtmlObject where+ toSElem (Scalar h) = STR $ TL.unpack $ unHtmlFragment $ cs h+ toSElem (Sequence hs) = LI $ map toSElem hs+ toSElem (Mapping pairs) = helper $ map (second toSElem) pairs where+ helper :: [(String, SElem b)] -> SElem b+ helper = SM . cs++#if TEST+caseHtmlToText :: Assertion+caseHtmlToText = do+ let actual = Tag "div" [("id", "foo"), ("class", "bar")] $ HtmlList+ [ Html $ cs "<br>Some HTML<br>"+ , Text $ cs "<'this should be escaped'>"+ , EmptyTag "img" [("src", "baz&")]+ ]+ let expected =+ "<div id=\"foo\" class=\"bar\"><br>Some HTML<br>" +++ "<'this should be escaped'>" +++ "<img src=\"baz&\"></div>"+ unHtmlFragment (cs actual) @?= (cs expected :: Text)++caseStringTemplate :: Assertion+caseStringTemplate = do+ let content = Mapping+ [ ("foo", Sequence [ Scalar $ Html $ cs "<br>"+ , Scalar $ Text $ cs "<hr>"])+ , ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")])+ ]+ let temp = newSTMP "foo:$o.foo$,bar:$o.bar$"+ let expected = "foo:<br><hr>,bar:<img src=\"file.jpg\">"+ expected @=? toString (setAttribute "o" content temp)++caseJson :: Assertion+caseJson = do+ let content = Mapping+ [ ("foo", Sequence [ Scalar $ Html $ cs "<br>"+ , Scalar $ Text $ cs "<hr>"])+ , ("bar", Scalar $ EmptyTag "img" [("src", "file.jpg")])+ ]+ let expected = "{\"bar\":\"<img src=\\\"file.jpg\\\">\"" +++ ",\"foo\":[\"<br>\",\"<hr>\"]" +++ "}"+ JsonDoc (cs expected) @=? cs content++testSuite :: Test+testSuite = testGroup "Data.Object.Html"+ [ testCase "caseHtmlToText" caseHtmlToText+ , testCase "caseStringTemplate" caseStringTemplate+ , testCase "caseJson" caseJson+ ]++#endif
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2009, Michael Snoyman. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,11 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple+> import System.Cmd (system)++> main :: IO ()+> main = defaultMainWithHooks (simpleUserHooks { runTests = runTests' })++> runTests' :: a -> b -> c -> d -> IO ()+> runTests' _ _ _ _ = system "runhaskell -DTEST runtests.hs" >> return ()
+ Web/Mime.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE CPP #-}+-- | Generic MIME type module. Could be spun off into its own package.+module Web.Mime+ ( ContentType (..)+ , contentTypeFromBS+ , typeByExt+ , ext+ , simpleContentType+#if TEST+ , testSuite+#endif+ ) where++import Data.Function (on)+import Data.Convertible.Text+import Data.ByteString.Char8 (pack, ByteString, unpack)++#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 Control.Monad (when)+#endif++data ContentType =+ TypeHtml+ | TypePlain+ | TypeJson+ | TypeXml+ | TypeAtom+ | TypeJpeg+ | TypePng+ | TypeGif+ | TypeJavascript+ | TypeCss+ | TypeFlv+ | TypeOgv+ | TypeOctet+ | TypeOther String+ deriving (Show)++instance ConvertSuccess ContentType ByteString where+ convertSuccess = pack . cs++instance ConvertSuccess ContentType [Char] where+ convertSuccess TypeHtml = "text/html; charset=utf-8"+ convertSuccess TypePlain = "text/plain; charset=utf-8"+ convertSuccess TypeJson = "application/json; charset=utf-8"+ convertSuccess TypeXml = "text/xml"+ convertSuccess TypeAtom = "application/atom+xml"+ convertSuccess TypeJpeg = "image/jpeg"+ convertSuccess TypePng = "image/png"+ convertSuccess TypeGif = "image/gif"+ convertSuccess TypeJavascript = "text/javascript; charset=utf-8"+ convertSuccess TypeCss = "text/css; charset=utf-8"+ convertSuccess TypeFlv = "video/x-flv"+ convertSuccess TypeOgv = "video/ogg"+ convertSuccess TypeOctet = "application/octet-stream"+ convertSuccess (TypeOther s) = s++simpleContentType :: ContentType -> String+simpleContentType = fst . span (/= ';') . cs++instance Eq ContentType where+ (==) = (==) `on` (cs :: ContentType -> String)++contentTypeFromBS :: ByteString -> ContentType+contentTypeFromBS = TypeOther . unpack++-- | Determine a mime-type based on the file extension.+typeByExt :: String -> ContentType+typeByExt "jpg" = TypeJpeg+typeByExt "jpeg" = TypeJpeg+typeByExt "js" = TypeJavascript+typeByExt "css" = TypeCss+typeByExt "html" = TypeHtml+typeByExt "png" = TypePng+typeByExt "gif" = TypeGif+typeByExt "txt" = TypePlain+typeByExt "flv" = TypeFlv+typeByExt "ogv" = TypeOgv+typeByExt _ = TypeOctet++-- | Get a file extension (everything after last period).+ext :: String -> String+ext = reverse . fst . break (== '.') . reverse++#if TEST+---- Testing+testSuite :: Test+testSuite = testGroup "Yesod.Resource"+ [ testProperty "ext" propExt+ , testCase "typeByExt" caseTypeByExt+ ]++propExt :: String -> Bool+propExt s =+ let s' = filter (/= '.') s+ in s' == ext ("foobarbaz." ++ s')++caseTypeByExt :: Assertion+caseTypeByExt = do+ TypeJavascript @=? typeByExt (ext "foo.js")+ TypeHtml @=? typeByExt (ext "foo.html")++#endif
+ Yesod.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE CPP #-}+---------------------------------------------------------+--+-- Module : Yesod+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Stable+-- Portability : portable+--+-- Lightweight framework for designing RESTful APIs.+--+---------------------------------------------------------+module Yesod+ (+ module Yesod.Request+ , module Yesod.Response+ , module Yesod.Yesod+ , module Yesod.Definitions+ , module Yesod.Handler+ , module Yesod.Resource+ , module Yesod.Form+ , module Data.Object.Html+ , module Yesod.Template+ , module Web.Mime+ , Application+ , Method (..)+ ) where++#if TEST+import Yesod.Resource hiding (testSuite)+import Yesod.Response hiding (testSuite)+import Data.Object.Html hiding (testSuite)+import Yesod.Request hiding (testSuite)+import Web.Mime hiding (testSuite)+#else+import Yesod.Resource+import Yesod.Response+import Data.Object.Html+import Yesod.Request+import Web.Mime+#endif++import Yesod.Form+import Yesod.Yesod+import Yesod.Definitions+import Yesod.Handler+import Network.Wai (Application, Method (..))+import Yesod.Template
+ Yesod/Definitions.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+---------------------------------------------------------+--+-- Module : Yesod.Definitions+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Stable+-- Portability : portable+--+-- Definitions throughout Restful.+--+---------------------------------------------------------+module Yesod.Definitions+ ( Resource+ , Approot+ , Language+ , Location (..)+ , showLocation+ -- * Constant values+ , authCookieName+ , authDisplayName+ , encryptedCookies+ , langKey+ , destCookieName+ , destCookieTimeout+ ) where++import Data.ByteString.Char8 (pack, ByteString)++type Resource = [String]++-- | An absolute URL to the base of this application. This can almost be done+-- programatically, but due to ambiguities in different ways of doing URL+-- rewriting for (fast)cgi applications, it should be supplied by the user.+type Approot = String++type Language = String++-- | A location string. Can either be given absolutely or as a suffix for the+-- 'Approot'.+data Location = AbsLoc String | RelLoc String++-- | Display a 'Location' in absolute form.+showLocation :: Approot -> Location -> String+showLocation _ (AbsLoc s) = s+showLocation ar (RelLoc s) = ar ++ s++authCookieName :: String+authCookieName = "IDENTIFIER"++authDisplayName :: String+authDisplayName = "DISPLAY_NAME"++encryptedCookies :: [ByteString]+encryptedCookies = [pack authDisplayName, pack authCookieName]++langKey :: String+langKey = "_LANG"++destCookieName :: String+destCookieName = "DEST"++destCookieTimeout :: Int+destCookieTimeout = 120
+ Yesod/Form.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PackageImports #-}+-- | Parse forms (and query strings).+module Yesod.Form+ ( Form (..)+ , runFormGeneric+ , runFormPost+ , runFormGet+ , input+ , applyForm+ -- * Specific checks+ , required+ , optional+ , notEmpty+ , checkDay+ , checkBool+ , checkInteger+ -- * Utility+ , catchFormError+ ) where++import Yesod.Request+import Yesod.Response (ErrorResponse)+import Yesod.Handler+import Control.Applicative hiding (optional)+import Data.Time (Day)+import Data.Convertible.Text+import Data.Attempt+import Data.Maybe (fromMaybe)+import "transformers" Control.Monad.Trans (MonadIO)+import qualified Safe.Failure++noParamNameError :: String+noParamNameError = "No param name (miscalling of Yesod.Form library)"++data Form x = Form (+ (ParamName -> [ParamValue])+ -> Either [(ParamName, FormError)] (Maybe ParamName, x)+ )++instance Functor Form where+ fmap f (Form x) = Form $ \l -> case x l of+ Left errors -> Left errors+ Right (pn, x') -> Right (pn, f x')+instance Applicative Form where+ pure x = Form $ \_ -> Right (Nothing, x)+ (Form f') <*> (Form x') = Form $ \l -> case (f' l, x' l) of+ (Right (_, f), Right (_, x)) -> Right $ (Nothing, f x)+ (Left e1, Left e2) -> Left $ e1 ++ e2+ (Left e, _) -> Left e+ (_, Left e) -> Left e++type FormError = String++runFormGeneric :: MonadFailure ErrorResponse m+ => (ParamName -> [ParamValue]) -> Form x -> m x+runFormGeneric params (Form f) =+ case f params of+ Left es -> invalidArgs es+ Right (_, x) -> return x++-- | Run a form against POST parameters.+runFormPost :: (RequestReader m, MonadFailure ErrorResponse m, MonadIO m)+ => Form x -> m x+runFormPost f = do+ rr <- getRequest+ pp <- postParams rr+ runFormGeneric pp f++-- | Run a form against GET parameters.+runFormGet :: (RequestReader m, MonadFailure ErrorResponse m)+ => Form x -> m x+runFormGet f = do+ rr <- getRequest+ runFormGeneric (getParams rr) f++input :: ParamName -> Form [ParamValue]+input pn = Form $ \l -> Right $ (Just pn, l pn)++applyForm :: (x -> Either FormError y) -> Form x -> Form y+applyForm f (Form x') =+ Form $ \l ->+ case x' l of+ Left e -> Left e+ Right (pn, x) ->+ case f x of+ Left e -> Left [(fromMaybe noParamNameError pn, e)]+ Right y -> Right (pn, y)++required :: Form [ParamValue] -> Form ParamValue+required = applyForm $ \pvs -> case pvs of+ [x] -> Right x+ [] -> Left "No value for required field"+ _ -> Left "Multiple values for required field"++optional :: Form [ParamValue] -> Form (Maybe ParamValue)+optional = applyForm $ \pvs -> case pvs of+ [""] -> Right Nothing+ [x] -> Right $ Just x+ [] -> Right Nothing+ _ -> Left "Multiple values for optional field"++notEmpty :: Form ParamValue -> Form ParamValue+notEmpty = applyForm $ \pv ->+ if null pv+ then Left "Value required"+ else Right pv++checkDay :: Form ParamValue -> Form Day+checkDay = applyForm $ attempt (const (Left "Invalid day")) Right . ca++checkBool :: Form [ParamValue] -> Form Bool+checkBool = applyForm $ \pv -> Right $ case pv of+ [] -> False+ [""] -> False+ ["false"] -> False+ _ -> True++checkInteger :: Form ParamValue -> Form Integer+checkInteger = applyForm $ \pv ->+ case Safe.Failure.read pv of+ Nothing -> Left "Invalid integer"+ Just i -> Right i++-- | Instead of calling 'failure' with an 'InvalidArgs', return the error+-- messages.+catchFormError :: Form x -> Form (Either [(ParamName, FormError)] x)+catchFormError (Form x) = Form $ \l ->+ case x l of+ Left e -> Right (Nothing, Left e)+ Right (_, v) -> Right (Nothing, Right v)
+ Yesod/Handler.hs view
@@ -0,0 +1,171 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PackageImports #-}+---------------------------------------------------------+--+-- Module : Yesod.Handler+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : unstable+-- Portability : portable+--+-- Define Handler stuff.+--+---------------------------------------------------------+module Yesod.Handler+ ( -- * Handler monad+ Handler+ , getYesod+ , runHandler+ , liftIO+ -- * Special handlers+ , redirect+ , sendFile+ , notFound+ , permissionDenied+ , invalidArgs+ -- * Setting headers+ , addCookie+ , deleteCookie+ , header+ ) where++import Yesod.Request+import Yesod.Response+import Web.Mime++import Control.Exception hiding (Handler)+import Control.Applicative++import "transformers" Control.Monad.Trans+import Control.Monad.Attempt+import Control.Monad (liftM, ap)++import System.IO+import Data.Object.Html+import qualified Data.ByteString.Lazy as BL+import qualified Network.Wai as W++data HandlerData yesod = HandlerData Request yesod++------ Handler monad+newtype Handler yesod a = Handler {+ unHandler :: HandlerData yesod+ -> IO ([Header], HandlerContents a)+}+data HandlerContents a =+ HCSpecial SpecialResponse+ | HCError ErrorResponse+ | HCContent a++instance Functor (Handler yesod) where+ fmap = liftM+instance Applicative (Handler yesod) where+ pure = return+ (<*>) = ap+instance Monad (Handler yesod) where+ fail = failure . InternalError -- We want to catch all exceptions anyway+ return x = Handler $ \_ -> return ([], HCContent x)+ (Handler handler) >>= f = Handler $ \rr -> do+ (headers, c) <- handler rr+ (headers', c') <-+ case c of+ (HCError e) -> return ([], HCError e)+ (HCSpecial e) -> return ([], HCSpecial e)+ (HCContent a) -> unHandler (f a) rr+ return (headers ++ headers', c')+instance MonadIO (Handler yesod) where+ liftIO i = Handler $ \_ -> i >>= \i' -> return ([], HCContent i')+instance Failure ErrorResponse (Handler yesod) where+ failure e = Handler $ \_ -> return ([], HCError e)+instance RequestReader (Handler yesod) where+ getRequest = Handler $ \(HandlerData rr _)+ -> return ([], HCContent rr)++getYesod :: Handler yesod yesod+getYesod = Handler $ \(HandlerData _ yesod) -> return ([], HCContent yesod)++runHandler :: Handler yesod ChooseRep+ -> (ErrorResponse -> Handler yesod ChooseRep)+ -> Request+ -> yesod+ -> [ContentType]+ -> IO Response+runHandler handler eh rr y cts = do+ let toErrorHandler =+ InternalError+ . (show :: Control.Exception.SomeException -> String)+ (headers, contents) <- Control.Exception.catch+ (unHandler handler $ HandlerData rr y)+ (\e -> return ([], HCError $ toErrorHandler e))+ let handleError e = do+ Response _ hs ct c <- runHandler (eh e) safeEh rr y cts+ let hs' = headers ++ hs+ return $ Response (getStatus e) hs' ct c+ let sendFile' ct fp = do+ c <- BL.readFile fp+ return $ Response W.Status200 headers ct $ cs c+ case contents of+ HCError e -> handleError e+ HCSpecial (Redirect rt loc) -> do+ let hs = Header "Location" loc : headers+ return $ Response (getRedirectStatus rt) hs TypePlain $ cs ""+ HCSpecial (SendFile ct fp) -> Control.Exception.catch+ (sendFile' ct fp)+ (handleError . toErrorHandler)+ HCContent a -> do+ (ct, c) <- a cts+ return $ Response W.Status200 headers ct c++safeEh :: ErrorResponse -> Handler yesod ChooseRep+safeEh er = do+ liftIO $ hPutStrLn stderr $ "Error handler errored out: " ++ show er+ return $ chooseRep+ ( Tag "title" [] $ cs "Internal Server Error"+ , toHtmlObject "Internal server error"+ )++------ Special handlers+specialResponse :: SpecialResponse -> Handler yesod a+specialResponse er = Handler $ \_ -> return ([], HCSpecial er)++-- | Redirect to the given URL.+redirect :: RedirectType -> String -> Handler yesod a+redirect rt = specialResponse . Redirect rt++sendFile :: ContentType -> FilePath -> Handler yesod a+sendFile ct = specialResponse . SendFile ct++-- | Return a 404 not found page. Also denotes no handler available.+notFound :: Failure ErrorResponse m => m a+notFound = failure NotFound++permissionDenied :: Failure ErrorResponse m => m a+permissionDenied = failure PermissionDenied++invalidArgs :: Failure ErrorResponse m => [(ParamName, String)] -> m a+invalidArgs = failure . InvalidArgs++------- Headers+-- | Set the cookie on the client.+addCookie :: Int -- ^ minutes to timeout+ -> String -- ^ key+ -> String -- ^ value+ -> Handler yesod ()+addCookie a b = addHeader . AddCookie a b++-- | Unset the cookie on the client.+deleteCookie :: String -> Handler yesod ()+deleteCookie = addHeader . DeleteCookie++-- | Set an arbitrary header on the client.+header :: String -> String -> Handler yesod ()+header a = addHeader . Header a++addHeader :: Header -> Handler yesod ()+addHeader h = Handler $ \_ -> return ([h], HCContent ())
+ Yesod/Helpers/AtomFeed.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+---------------------------------------------------------+--+-- Module : Yesod.Helpers.AtomFeed+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Stable+-- Portability : portable+--+-- Generating atom news feeds.+--+---------------------------------------------------------++module Yesod.Helpers.AtomFeed+ ( AtomFeed (..)+ , AtomFeedEntry (..)+ , AtomFeedResponse (..)+ , atomFeed+ ) where++import Yesod+import Data.Time.Clock (UTCTime)+import Web.Encodings (formatW3)++data AtomFeedResponse = AtomFeedResponse AtomFeed Approot++atomFeed :: YesodApproot y => AtomFeed -> Handler y AtomFeedResponse+atomFeed f = do+ y <- getYesod+ return $ AtomFeedResponse f $ approot y++data AtomFeed = AtomFeed+ { atomTitle :: String+ , atomLinkSelf :: Location+ , atomLinkHome :: Location+ , atomUpdated :: UTCTime+ , atomEntries :: [AtomFeedEntry]+ }+instance HasReps AtomFeedResponse where+ chooseRep = defChooseRep+ [ (TypeAtom, return . cs)+ ]++data AtomFeedEntry = AtomFeedEntry+ { atomEntryLink :: Location+ , atomEntryUpdated :: UTCTime+ , atomEntryTitle :: String+ , atomEntryContent :: Html+ }++instance ConvertSuccess AtomFeedResponse Content where+ convertSuccess = cs . (cs :: Html -> XmlDoc) . cs+instance ConvertSuccess AtomFeedResponse Html where+ convertSuccess (AtomFeedResponse f ar) =+ Tag "feed" [("xmlns", "http://www.w3.org/2005/Atom")] $ HtmlList+ [ Tag "title" [] $ cs $ atomTitle f+ , EmptyTag "link" [ ("rel", "self")+ , ("href", showLocation ar $ atomLinkSelf f)+ ]+ , EmptyTag "link" [ ("href", showLocation ar $ atomLinkHome f)+ ]+ , Tag "updated" [] $ cs $ formatW3 $ atomUpdated f+ , Tag "id" [] $ cs $ showLocation ar $ atomLinkHome f+ , HtmlList $ map cs $ zip (atomEntries f) $ repeat ar+ ]++instance ConvertSuccess (AtomFeedEntry, Approot) Html where+ convertSuccess (e, ar) = Tag "entry" [] $ HtmlList+ [ Tag "id" [] $ cs $ showLocation ar $ atomEntryLink e+ , EmptyTag "link" [("href", showLocation ar $ atomEntryLink e)]+ , Tag "updated" [] $ cs $ formatW3 $ atomEntryUpdated e+ , Tag "title" [] $ cs $ atomEntryTitle e+ , Tag "content" [("type", "html")] $ cdata $ atomEntryContent e+ ]
+ Yesod/Helpers/Auth.hs view
@@ -0,0 +1,260 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}+---------------------------------------------------------+--+-- Module : Yesod.Helpers.Auth+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Stable+-- Portability : portable+--+-- Authentication through the authentication package.+--+---------------------------------------------------------+module Yesod.Helpers.Auth+ ( authHandler+ , YesodAuth (..)+ , maybeIdentifier+ , authIdentifier+ , displayName+ , redirectLogin+ ) where++import Web.Encodings+import qualified Web.Authenticate.Rpxnow as Rpxnow+import qualified Web.Authenticate.OpenId as OpenId++import Yesod++import Control.Monad.Attempt+import qualified Data.ByteString.Char8 as B8++import Data.Maybe (fromMaybe)+import qualified Network.Wai as W+import Data.Typeable (Typeable)+import Control.Exception (Exception)+import Control.Applicative ((<$>))++-- FIXME check referer header to determine destination++class YesodApproot a => YesodAuth a where+ -- | The following breaks DRY, but I cannot think of a better solution+ -- right now.+ --+ -- The root relative to the application root. Should not begin with a slash+ -- and should end with one.+ authRoot :: a -> String+ authRoot _ = "auth/"++ -- | Absolute path to the default login path.+ defaultLoginPath :: a -> String+ defaultLoginPath a = approot a ++ authRoot a ++ "openid/"++ rpxnowApiKey :: a -> Maybe String+ rpxnowApiKey _ = Nothing++ onRpxnowLogin :: Rpxnow.Identifier -> Handler a ()+ onRpxnowLogin _ = return ()++getFullAuthRoot :: YesodAuth y => Handler y String+getFullAuthRoot = do+ y <- getYesod+ ar <- getApproot+ return $ ar ++ authRoot y++data AuthResource =+ Check+ | Logout+ | Openid+ | OpenidForward+ | OpenidComplete+ | LoginRpxnow+ deriving (Show, Eq, Enum, Bounded)++rc :: HasReps x => Handler y x -> Handler y ChooseRep+rc = fmap chooseRep++authHandler :: YesodAuth y => W.Method -> [String] -> Handler y ChooseRep+authHandler W.GET ["check"] = rc authCheck+authHandler W.GET ["logout"] = rc authLogout+authHandler W.GET ["openid"] = rc authOpenidForm+authHandler W.GET ["openid", "forward"] = rc authOpenidForward+authHandler W.GET ["openid", "complete"] = rc authOpenidComplete+-- two different versions of RPX protocol apparently, so just accepting all+-- verbs+authHandler _ ["login", "rpxnow"] = rc rpxnowLogin+authHandler _ _ = notFound++data OIDFormReq = OIDFormReq (Maybe String) (Maybe String)+instance ConvertSuccess OIDFormReq Html where+ convertSuccess (OIDFormReq Nothing _) = cs ""+ convertSuccess (OIDFormReq (Just s) _) =+ Tag "p" [("class", "message")] $ cs s++data ExpectedSingleParam = ExpectedSingleParam+ deriving (Show, Typeable)+instance Exception ExpectedSingleParam++authOpenidForm :: Yesod y => Handler y ChooseRep+authOpenidForm = do+ rr <- getRequest+ case getParams rr "dest" of+ [] -> return ()+ (x:_) -> addCookie destCookieTimeout destCookieName x+ let html =+ HtmlList+ [ case getParams rr "message" of+ [] -> HtmlList []+ (m:_) -> Tag "p" [("class", "message")] $ cs m+ , Tag "form" [("method", "get"), ("action", "forward/")] $+ HtmlList+ [ Tag "label" [("for", "openid")] $ cs "OpenID: "+ , EmptyTag "input" [("type", "text"), ("id", "openid"),+ ("name", "openid")]+ , EmptyTag "input" [("type", "submit"), ("value", "Login")]+ ]+ ]+ applyLayout' "Log in via OpenID" html++authOpenidForward :: YesodAuth y => Handler y ()+authOpenidForward = do+ rr <- getRequest+ oid <- case getParams rr "openid" of+ [x] -> return x+ _ -> invalidArgs [("openid", show ExpectedSingleParam)]+ authroot <- getFullAuthRoot+ let complete = authroot ++ "/openid/complete/"+ res <- runAttemptT $ OpenId.getForwardUrl oid complete+ attempt+ (\err -> redirect RedirectTemporary+ $ "/auth/openid/?message=" ++ encodeUrl (show err))+ (redirect RedirectTemporary)+ res++authOpenidComplete :: YesodApproot y => Handler y ()+authOpenidComplete = do+ rr <- getRequest+ let gets' = reqGetParams rr+ res <- runAttemptT $ OpenId.authenticate gets'+ let onFailure err = redirect RedirectTemporary+ $ "/auth/openid/?message="+ ++ encodeUrl (show err)+ let onSuccess (OpenId.Identifier ident) = do+ ar <- getApproot+ header authCookieName ident+ redirectToDest RedirectTemporary ar+ attempt onFailure onSuccess res++rpxnowLogin :: YesodAuth y => Handler y ()+rpxnowLogin = do+ ay <- getYesod+ let ar = approot ay+ apiKey <- case rpxnowApiKey ay of+ Just x -> return x+ Nothing -> notFound+ rr <- getRequest+ pp <- postParams rr+ let token = case getParams rr "token" ++ pp "token" of+ [] -> failure MissingToken+ (x:_) -> x+ let dest = case pp "dest" of+ [] -> case getParams rr "dest" of+ [] -> ar+ ("":_) -> ar+ (('#':rest):_) -> rest+ (s:_) -> s+ (d:_) -> d+ ident <- liftIO $ Rpxnow.authenticate apiKey token+ onRpxnowLogin ident+ header authCookieName $ Rpxnow.identifier ident+ header authDisplayName $ getDisplayName ident+ redirectToDest RedirectTemporary dest++data MissingToken = MissingToken+ deriving (Show, Typeable)+instance Exception MissingToken++-- | Get some form of a display name, defaulting to the identifier.+getDisplayName :: Rpxnow.Identifier -> String+getDisplayName (Rpxnow.Identifier ident extra) = helper choices where+ choices = ["verifiedEmail", "email", "displayName", "preferredUsername"]+ helper [] = ident+ helper (x:xs) = case lookup x extra of+ Nothing -> helper xs+ Just y -> y++authCheck :: Yesod y => Handler y ChooseRep+authCheck = do+ ident <- maybeIdentifier+ dn <- displayName+ applyLayoutJson "Authentication Status" $ cs+ [ ("identifier", fromMaybe "" ident)+ , ("displayName", fromMaybe "" dn)+ ]++authLogout :: YesodAuth y => Handler y ()+authLogout = do+ deleteCookie authCookieName+ getApproot >>= redirectToDest RedirectTemporary++-- | Gets the identifier for a user if available.+maybeIdentifier :: (Functor m, Monad m, RequestReader m) => m (Maybe String)+maybeIdentifier =+ fmap cs . lookup (B8.pack authCookieName) . reqSession+ <$> getRequest++-- | Gets the display name for a user if available.+displayName :: (Functor m, Monad m, RequestReader m) => m (Maybe String)+displayName = do+ rr <- getRequest+ return $ fmap cs $ lookup (B8.pack authDisplayName) $ reqSession rr++-- | Gets the identifier for a user. If user is not logged in, redirects them+-- to the login page.+authIdentifier :: YesodAuth y => Handler y String+authIdentifier = maybeIdentifier >>= maybe redirectLogin return++-- | Redirect the user to the 'defaultLoginPath', setting the DEST cookie+-- appropriately.+redirectLogin :: YesodAuth y => Handler y a+redirectLogin =+ defaultLoginPath `fmap` getYesod >>= redirectSetDest RedirectTemporary++-- | Determinge the path requested by the user (ie, the path info). This+-- includes the query string.+requestPath :: (Functor m, Monad m, RequestReader m) => m String+requestPath = do+ env <- waiRequest+ let q = case B8.unpack $ W.queryString env of+ "" -> ""+ q'@('?':_) -> q'+ q' -> '?' : q'+ return $! dropSlash (B8.unpack $ W.pathInfo env) ++ q+ where+ dropSlash ('/':x) = x+ dropSlash x = x++-- | Redirect to the given URL, and set a cookie with the current URL so the+-- user will ultimately be sent back here.+redirectSetDest :: YesodApproot y => RedirectType -> String -> Handler y a+redirectSetDest rt dest = do+ ar <- getApproot+ rp <- requestPath+ let curr = ar ++ rp+ addCookie destCookieTimeout destCookieName curr+ redirect rt dest++-- | Read the 'destCookieName' cookie and redirect to this destination. If the+-- cookie is missing, then use the default path provided.+redirectToDest :: RedirectType -> String -> Handler y a+redirectToDest rt def = do+ rr <- getRequest+ dest <- case cookies rr destCookieName of+ [] -> return def+ (x:_) -> do+ deleteCookie destCookieName+ return x+ redirect rt dest
+ Yesod/Helpers/Sitemap.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+---------------------------------------------------------+--+-- Module : Yesod.Helpers.Sitemap+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Stable+-- Portability : portable+--+-- Generating Google sitemap files.+--+---------------------------------------------------------++module Yesod.Helpers.Sitemap+ ( sitemap+ , robots+ , SitemapUrl (..)+ , SitemapChangeFreq (..)+ , SitemapResponse (..)+ ) where++import Yesod+import Web.Encodings (formatW3)+import Data.Time (UTCTime)++data SitemapChangeFreq = Always+ | Hourly+ | Daily+ | Weekly+ | Monthly+ | Yearly+ | Never+instance ConvertSuccess SitemapChangeFreq String where+ convertSuccess Always = "always"+ convertSuccess Hourly = "hourly"+ convertSuccess Daily = "daily"+ convertSuccess Weekly = "weekly"+ convertSuccess Monthly = "monthly"+ convertSuccess Yearly = "yearly"+ convertSuccess Never = "never"+instance ConvertSuccess SitemapChangeFreq Html where+ convertSuccess = (cs :: String -> Html) . cs++data SitemapUrl = SitemapUrl+ { sitemapLoc :: Location+ , sitemapLastMod :: UTCTime+ , sitemapChangeFreq :: SitemapChangeFreq+ , priority :: Double+ }+data SitemapResponse = SitemapResponse [SitemapUrl] Approot+instance ConvertSuccess SitemapResponse Content where+ convertSuccess = cs . (cs :: Html -> XmlDoc) . cs+instance ConvertSuccess SitemapResponse Html where+ convertSuccess (SitemapResponse urls ar) =+ Tag "urlset" [("xmlns", sitemapNS)] $ HtmlList $ map helper urls+ where+ sitemapNS = "http://www.sitemaps.org/schemas/sitemap/0.9"+ helper :: SitemapUrl -> Html+ helper (SitemapUrl loc modTime freq pri) =+ Tag "url" [] $ HtmlList+ [ Tag "loc" [] $ cs $ showLocation ar loc+ , Tag "lastmod" [] $ cs $ formatW3 modTime+ , Tag "changefreq" [] $ cs freq+ , Tag "priority" [] $ cs $ show pri+ ]++instance HasReps SitemapResponse where+ chooseRep = defChooseRep+ [ (TypeXml, return . cs)+ ]++sitemap :: YesodApproot y => [SitemapUrl] -> Handler y SitemapResponse+sitemap urls = do+ yesod <- getYesod+ return $ SitemapResponse urls $ approot yesod++robots :: YesodApproot yesod => Handler yesod [(ContentType, Content)]+robots = do+ yesod <- getYesod+ return $ staticRep TypePlain $ "Sitemap: " ++ showLocation+ (approot yesod)+ (RelLoc "sitemap.xml")
+ Yesod/Helpers/Static.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+---------------------------------------------------------+--+-- Module : Yesod.Helpers.Static+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Unstable+-- Portability : portable+--+-- Serve static files from a Yesod app.+--+-- This is most useful for standalone testing. When running on a production+-- server (like Apache), just let the server do the static serving.+--+---------------------------------------------------------+module Yesod.Helpers.Static+ ( serveStatic+ , FileLookup+ , fileLookupDir+ ) where++import System.Directory (doesFileExist)+import Control.Monad++import Yesod+import Data.List (intercalate)++type FileLookup = FilePath -> IO (Maybe (Either FilePath Content))++-- | A 'FileLookup' for files in a directory. Note that this function does not+-- check if the requested path does unsafe things, eg expose hidden files. You+-- should provide this checking elsewhere.+--+-- If you are just using this in combination with serveStatic, serveStatic+-- provides this checking.+fileLookupDir :: FilePath -> FileLookup+fileLookupDir dir fp = do+ let fp' = dir ++ '/' : fp+ exists <- doesFileExist fp'+ if exists+ then return $ Just $ Left fp'+ else return Nothing++serveStatic :: FileLookup -> Method -> [String]+ -> Handler y [(ContentType, Content)]+serveStatic fl GET fp = getStatic fl fp+serveStatic _ _ _ = notFound++getStatic :: FileLookup -> [String] -> Handler y [(ContentType, Content)]+getStatic fl fp' = do+ when (any isUnsafe fp') notFound+ let fp = intercalate "/" fp'+ content <- liftIO $ fl fp+ case content of+ Nothing -> notFound+ Just (Left fp'') -> sendFile (typeByExt $ ext fp'') fp''+ Just (Right bs) -> return [(typeByExt $ ext fp, cs bs)]+ where+ isUnsafe [] = True+ isUnsafe ('.':_) = True+ isUnsafe _ = False
+ Yesod/Request.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+---------------------------------------------------------+--+-- Module : Yesod.Request+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Stable+-- Portability : portable+--+-- Code for extracting parameters from requests.+--+---------------------------------------------------------+module Yesod.Request+ (+ -- * Request+ Request (..)+ , RequestReader (..)+ , waiRequest+ , cookies+ , getParams+ , postParams+ , languages+ , parseWaiRequest+ -- * Parameter+ , ParamName+ , ParamValue+ , ParamError+#if TEST+ , testSuite+#endif+ ) where++import qualified Network.Wai as W+import Data.Function.Predicate (equals)+import Yesod.Definitions+import Web.Encodings+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Convertible.Text+import Control.Arrow ((***))+import Data.Maybe (fromMaybe)+import "transformers" Control.Monad.Trans+import Control.Concurrent.MVar++#if TEST+import Test.Framework (testGroup, Test)+--import Test.Framework.Providers.HUnit+--import Test.HUnit hiding (Test)+#endif++type ParamName = String+type ParamValue = String+type ParamError = String++class RequestReader m where+ getRequest :: m Request+instance RequestReader ((->) Request) where+ getRequest = id++languages :: (Functor m, RequestReader m) => m [Language]+languages = reqLangs `fmap` getRequest++-- | Get the req 'W.Request' value.+waiRequest :: (Functor m, RequestReader m) => m W.Request+waiRequest = reqWaiRequest `fmap` getRequest++type RequestBodyContents =+ ( [(ParamName, ParamValue)]+ , [(ParamName, FileInfo String BL.ByteString)]+ )++-- | The req information passed through W, cleaned up a bit.+data Request = Request+ { reqGetParams :: [(ParamName, ParamValue)]+ , reqCookies :: [(ParamName, ParamValue)]+ , reqSession :: [(B.ByteString, B.ByteString)]+ , reqRequestBody :: IO RequestBodyContents+ , reqWaiRequest :: W.Request+ , reqLangs :: [Language]+ }++multiLookup :: [(ParamName, ParamValue)] -> ParamName -> [ParamValue]+multiLookup [] _ = []+multiLookup ((k, v):rest) pn+ | k == pn = v : multiLookup rest pn+ | otherwise = multiLookup rest pn++-- | All GET paramater values with the given name.+getParams :: Request -> ParamName -> [ParamValue]+getParams rr = multiLookup $ reqGetParams rr++-- | All POST paramater values with the given name.+postParams :: MonadIO m => Request -> m (ParamName -> [ParamValue])+postParams rr = do+ (pp, _) <- liftIO $ reqRequestBody rr+ return $ multiLookup pp++-- | Produces a \"compute on demand\" value. The computation will be run once+-- it is requested, and then the result will be stored. This will happen only+-- once.+iothunk :: IO a -> IO (IO a)+iothunk = fmap go . newMVar . Left where+ go :: MVar (Either (IO a) a) -> IO a+ go mvar = modifyMVar mvar go'+ go' :: Either (IO a) a -> IO (Either (IO a) a, a)+ go' (Right val) = return (Right val, val)+ go' (Left comp) = do+ val <- comp+ return (Right val, val)++-- | All cookies with the given name.+cookies :: Request -> ParamName -> [ParamValue]+cookies rr name = map snd . filter (fst `equals` name) . reqCookies $ rr++parseWaiRequest :: W.Request+ -> [(B.ByteString, B.ByteString)] -- ^ session+ -> IO Request+parseWaiRequest env session = do+ let gets' = map (cs *** cs) $ decodeUrlPairs $ W.queryString env+ let reqCookie = fromMaybe B.empty $ lookup W.Cookie $ W.requestHeaders env+ cookies' = map (cs *** cs) $ parseCookies reqCookie+ acceptLang = lookup W.AcceptLanguage $ W.requestHeaders env+ langs = map cs $ maybe [] parseHttpAccept acceptLang+ langs' = case lookup langKey cookies' of+ Nothing -> langs+ Just x -> x : langs+ langs'' = case lookup langKey gets' of+ Nothing -> langs'+ Just x -> x : langs'+ rbthunk <- iothunk $ rbHelper env+ return $ Request gets' cookies' session rbthunk env langs''++rbHelper :: W.Request -> IO RequestBodyContents+rbHelper = fmap (fix1 *** map fix2) . parseRequestBody lbsSink where+ fix1 = map (cs *** cs)+ fix2 (x, FileInfo a b c) = (cs x, FileInfo (cs a) (cs b) c)++#if TEST+testSuite :: Test+testSuite = testGroup "Yesod.Request"+ [+ ]+#endif
+ Yesod/Resource.hs view
@@ -0,0 +1,532 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+---------------------------------------------------------+--+-- Module : Yesod.Resource+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Stable+-- Portability : portable+--+-- Defines the ResourceName class.+--+---------------------------------------------------------+module Yesod.Resource+ ( mkResources+ , mkResourcesNoCheck+#if TEST+ -- * Testing+ , testSuite+#endif+ ) where++import Data.List.Split (splitOn)+import Yesod.Definitions+import Data.List (nub)+import Data.Char (isDigit)++import Language.Haskell.TH.Syntax+import Language.Haskell.TH.Quote+import Network.Wai (Method (..), methodFromBS, methodToBS)+{- Debugging+import Language.Haskell.TH.Ppr+import System.IO+-}++import Data.Typeable+import Control.Exception (Exception)+import Data.Attempt -- for failure stuff+import Data.Object.Text+import Control.Monad ((<=<), unless, zipWithM)+import Data.Object.Yaml+import Yesod.Handler+import Data.Maybe (fromJust)+import Yesod.Response (chooseRep)+import Control.Arrow+import Data.ByteString (ByteString)++#if TEST+import Control.Monad (replicateM)+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++mkResources :: QuasiQuoter+mkResources = QuasiQuoter (strToExp True) undefined++mkResourcesNoCheck :: QuasiQuoter+mkResourcesNoCheck = QuasiQuoter (strToExp False) undefined++-- | Resource Pattern Piece+data RPP =+ Static String+ | DynStr String+ | DynInt String+ | Slurp String -- ^ take up the rest of the pieces. must be last+ deriving (Eq, Show)++-- | Resource Pattern+newtype RP = RP { unRP :: [RPP] }+ deriving (Eq, Show)++isSlurp :: RPP -> Bool+isSlurp (Slurp _) = True+isSlurp _ = False++data InvalidResourcePattern =+ SlurpNotLast String+ | EmptyResourcePatternPiece String+ deriving (Show, Typeable)+instance Exception InvalidResourcePattern+readRP :: MonadFailure InvalidResourcePattern m+ => ResourcePattern+ -> m RP+readRP "" = return $ RP []+readRP "/" = return $ RP []+readRP rps = fmap RP $ helper $ splitOn "/" $ correct rps where+ correct = correct1 . correct2 where+ correct1 ('/':rest) = rest+ correct1 x = x+ correct2 x+ | null x = x+ | last x == '/' = init x+ | otherwise = x+ helper [] = return []+ helper (('$':name):rest) = do+ rest' <- helper rest+ return $ DynStr name : rest'+ helper (('#':name):rest) = do+ rest' <- helper rest+ return $ DynInt name : rest'+ helper (('*':name):rest) = do+ rest' <- helper rest+ unless (null rest') $ failure $ SlurpNotLast rps+ return $ Slurp name : rest'+ helper ("":_) = failure $ EmptyResourcePatternPiece rps+ helper (name:rest) = do+ rest' <- helper rest+ return $ Static name : rest'+instance ConvertSuccess RP String where+ convertSuccess = concatMap helper . unRP where+ helper (Static s) = '/' : s+ helper (DynStr s) = '/' : '$' : s+ helper (Slurp s) = '/' : '*' : s+ helper (DynInt s) = '/' : '#' : s++type ResourcePattern = String++-- | Determing whether the given resource fits the resource pattern.+doesPatternMatch :: RP -> Resource -> Bool+doesPatternMatch rp r = case doPatternPiecesMatch (unRP rp) r of+ Nothing -> False+ _ -> True++-- | Extra the 'UrlParam's from a resource known to match the given 'RP'. This+-- is a partial function.+paramsFromMatchingPattern :: RP -> Resource -> [UrlParam]+paramsFromMatchingPattern rp =+ map snd . fromJust . doPatternPiecesMatch (unRP rp)++doPatternPiecesMatch :: MonadFailure NoMatch m+ => [RPP]+ -> Resource+ -> m [(String, UrlParam)]+doPatternPiecesMatch rp r+ | not (null rp) && isSlurp (last rp) = do+ let rp' = init rp+ (r1, r2) = splitAt (length rp') r+ smap <- doPatternPiecesMatch rp' r1+ let Slurp slurpKey = last rp+ return $ (slurpKey, SlurpParam r2) : smap+ | length rp /= length r = failure NoMatch+ | otherwise = concat `fmap` zipWithM doesPatternPieceMatch rp r++data NoMatch = NoMatch+doesPatternPieceMatch :: MonadFailure NoMatch m+ => RPP+ -> String+ -> m [(String, UrlParam)]+doesPatternPieceMatch (Static x) y = if x == y then return [] else failure NoMatch+doesPatternPieceMatch (DynStr x) y = return [(x, StringParam y)]+doesPatternPieceMatch (Slurp x) _ = error $ "Slurp pattern " ++ x ++ " must be last"+doesPatternPieceMatch (DynInt x) y+ | all isDigit y = return [(x, IntParam $ read y)]+ | otherwise = failure NoMatch++-- | Determine if two resource patterns can lead to an overlap (ie, they can+-- both match a single resource).+overlaps :: [RPP] -> [RPP] -> Bool+overlaps [] [] = True+overlaps [] _ = False+overlaps _ [] = False+overlaps (Slurp _:_) _ = True+overlaps _ (Slurp _:_) = True+overlaps (DynStr _:x) (_:y) = overlaps x y+overlaps (_:x) (DynStr _:y) = overlaps x y+overlaps (DynInt _:x) (DynInt _:y) = overlaps x y+overlaps (DynInt _:x) (Static s:y)+ | all isDigit s = overlaps x y+ | otherwise = False+overlaps (Static s:x) (DynInt _:y)+ | all isDigit s = overlaps x y+ | otherwise = False+overlaps (Static a:x) (Static b:y) = a == b && overlaps x y++data OverlappingPatterns =+ OverlappingPatterns [(ResourcePattern, ResourcePattern)]+ deriving (Show, Typeable, Eq)+instance Exception OverlappingPatterns++getAllPairs :: [x] -> [(x, x)]+getAllPairs [] = []+getAllPairs [_] = []+getAllPairs (x:xs) = map ((,) x) xs ++ getAllPairs xs++-- | Ensures that we have a consistent set of resource patterns.+checkPatterns :: (MonadFailure OverlappingPatterns m,+ MonadFailure InvalidResourcePattern m)+ => [ResourcePattern]+ -> m [RP]+checkPatterns rpss = do+ rps <- mapM (runKleisli $ Kleisli return &&& Kleisli readRP) rpss+ let overlaps' = concatMap helper $ getAllPairs rps+ unless (null overlaps') $ failure $ OverlappingPatterns overlaps'+ return $ map snd rps+ where+ helper :: ((ResourcePattern, RP), (ResourcePattern, RP))+ -> [(ResourcePattern, ResourcePattern)]+ helper ((a, RP x), (b, RP y))+ | overlaps x y = [(a, b)]+ | otherwise = []++data RPNode = RPNode RP MethodMap+ deriving (Show, Eq)+data MethodMap = AllMethods String | Methods [(Method, String)]+ deriving (Show, Eq)+instance ConvertAttempt TextObject [RPNode] where+ convertAttempt = mapM helper <=< fromMapping where+ helper :: (Text, TextObject) -> Attempt RPNode+ helper (rp, rest) = do+ verbMap <- fromTextObject rest+ rp' <- readRP $ cs rp+ return $ RPNode rp' verbMap+instance ConvertAttempt TextObject MethodMap where+ convertAttempt (Scalar s) = return $ AllMethods $ cs s+ convertAttempt (Mapping m) = Methods `fmap` mapM helper m where+ helper :: (Text, TextObject) -> Attempt (Method, String)+ helper (v, Scalar f) = return (methodFromBS $ cs v, cs f)+ helper (_, x) = failure $ MethodMapNonScalar x+ convertAttempt o = failure $ MethodMapSequence o+data RPNodeException = MethodMapNonScalar TextObject+ | MethodMapSequence TextObject+ deriving (Show, Typeable)+instance Exception RPNodeException++checkRPNodes :: (MonadFailure OverlappingPatterns m,+ MonadFailure RepeatedMethod m,+ MonadFailure InvalidResourcePattern m+ )+ => [RPNode]+ -> m [RPNode]+checkRPNodes nodes = do+ _ <- checkPatterns $ map (\(RPNode r _) -> cs r) nodes+ mapM_ (\(RPNode _ v) -> checkMethodMap v) nodes+ return nodes+ where+ checkMethodMap (AllMethods _) = return ()+ checkMethodMap (Methods vs) =+ let vs' = map fst vs+ res = nub vs' == vs'+ in unless res $ failure $ RepeatedMethod vs++newtype RepeatedMethod = RepeatedMethod [(Method, String)]+ deriving (Show, Typeable)+instance Exception RepeatedMethod++rpnodesTHCheck :: [RPNode] -> Q Exp+rpnodesTHCheck nodes = do+ nodes' <- runIO $ checkRPNodes nodes+ {- For debugging purposes+ rpnodesTH nodes' >>= runIO . putStrLn . pprint+ runIO $ hFlush stdout+ -}+ rpnodesTH nodes'++notFoundMethod :: Method -> Handler yesod a+notFoundMethod _verb = notFound++rpnodesTH :: [RPNode] -> Q Exp+rpnodesTH ns = do+ b <- mapM helper ns+ nfv <- [|notFoundMethod|]+ ow <- [|otherwise|]+ let b' = b ++ [(NormalG ow, nfv)]+ return $ LamE [VarP $ mkName "resource"]+ $ CaseE (TupE []) [Match WildP (GuardedB b') []]+ where+ helper :: RPNode -> Q (Guard, Exp)+ helper (RPNode rp vm) = do+ rp' <- lift rp+ cpb <- [|doesPatternMatch|]+ let r' = VarE $ mkName "resource"+ let g = cpb `AppE` rp' `AppE` r'+ vm' <- liftMethodMap vm r' rp+ let vm'' = LamE [VarP $ mkName "verb"] vm'+ return (NormalG g, vm'')++data UrlParam = SlurpParam { slurpParam :: [String] }+ | StringParam { stringParam :: String }+ | IntParam { intParam :: Integer }++getUrlParam :: RP -> Resource -> Int -> UrlParam+getUrlParam rp = (!!) . paramsFromMatchingPattern rp++getUrlParamSlurp :: RP -> Resource -> Int -> [String]+getUrlParamSlurp rp r = slurpParam . getUrlParam rp r++getUrlParamString :: RP -> Resource -> Int -> String+getUrlParamString rp r = stringParam . getUrlParam rp r++getUrlParamInt :: RP -> Resource -> Int -> Integer+getUrlParamInt rp r = intParam . getUrlParam rp r++applyUrlParams :: RP -> Exp -> Exp -> Q Exp+applyUrlParams rp@(RP rpps) r f = do+ getFs <- helper 0 rpps+ return $ foldl AppE f getFs+ where+ helper :: Int -> [RPP] -> Q [Exp]+ helper _ [] = return []+ helper i (Static _:rest) = helper i rest+ helper i (DynStr _:rest) = do+ rp' <- lift rp+ str <- [|getUrlParamString|]+ i' <- lift i+ rest' <- helper (i + 1) rest+ return $ str `AppE` rp' `AppE` r `AppE` i' : rest'+ helper i (DynInt _:rest) = do+ rp' <- lift rp+ int <- [|getUrlParamInt|]+ i' <- lift i+ rest' <- helper (i + 1) rest+ return $ int `AppE` rp' `AppE` r `AppE` i' : rest'+ helper i (Slurp _:rest) = do+ rp' <- lift rp+ slurp <- [|getUrlParamSlurp|]+ i' <- lift i+ rest' <- helper (i + 1) rest+ return $ slurp `AppE` rp' `AppE` r `AppE` i' : rest'++instance Lift RP where+ lift (RP rpps) = do+ rpps' <- lift rpps+ rp <- [|RP|]+ return $ rp `AppE` rpps'+instance Lift RPP where+ lift (Static s) = do+ st <- [|Static|]+ return $ st `AppE` (LitE $ StringL s)+ lift (DynStr s) = do+ d <- [|DynStr|]+ return $ d `AppE` (LitE $ StringL s)+ lift (DynInt s) = do+ d <- [|DynInt|]+ return $ d `AppE` (LitE $ StringL s)+ lift (Slurp s) = do+ sl <- [|Slurp|]+ return $ sl `AppE` (LitE $ StringL s)+liftMethodMap :: MethodMap -> Exp -> RP -> Q Exp+liftMethodMap (AllMethods s) r rp = do+ -- handler function+ let f = VarE $ mkName s+ -- applied to the verb+ let f' = f `AppE` VarE (mkName "verb")+ -- apply all the url params+ f'' <- applyUrlParams rp r f'+ -- and apply chooseRep+ cr <- [|fmap chooseRep|]+ let f''' = cr `AppE` f''+ return f'''+liftMethodMap (Methods vs) r rp = do+ cr <- [|fmap chooseRep|]+ vs' <- mapM (helper cr) vs+ return $ CaseE (TupE []) [Match WildP (GuardedB $ vs' ++ [whenNotFound]) []]+ --return $ CaseE (VarE $ mkName "verb") $ vs' ++ [whenNotFound]+ where+ helper :: Exp -> (Method, String) -> Q (Guard, Exp)+ helper cr (v, fName) = do+ method' <- liftMethod v+ equals <- [|(==)|]+ let eq = equals+ `AppE` method'+ `AppE` VarE ((mkName "verb"))+ let g = NormalG $ eq+ let f = VarE $ mkName fName+ f' <- applyUrlParams rp r f+ let f'' = cr `AppE` f'+ return (g, f'')+ whenNotFound :: (Guard, Exp)+ whenNotFound =+ (NormalG $ ConE $ mkName "True",+ VarE $ mkName "notFound")++liftMethod :: Method -> Q Exp+liftMethod m = do+ cs' <- [|cs :: String -> ByteString|]+ methodFromBS' <- [|methodFromBS|]+ let s = cs $ methodToBS m :: String+ s' <- liftString s+ return $ methodFromBS' `AppE` AppE cs' s'++strToExp :: Bool -> String -> Q Exp+strToExp toCheck s = do+ rpnodes <- runIO $ decode (cs s) >>= \to -> convertAttemptWrap (to :: TextObject)+ (if toCheck then rpnodesTHCheck else rpnodesTH) rpnodes++#if TEST+---- Testing+testSuite :: Test+testSuite = testGroup "Yesod.Resource"+ [ testCase "non-overlap" caseOverlap1+ , testCase "overlap" caseOverlap2+ , testCase "overlap-slurp" caseOverlap3+ , testCase "checkPatterns" caseCheckPatterns+ , testProperty "show pattern" prop_showPattern+ , testCase "integers" caseIntegers+ , testCase "read patterns from YAML" caseFromYaml+ , testCase "checkRPNodes" caseCheckRPNodes+ , testCase "readRP" caseReadRP+ ]++instance Arbitrary RP where+ arbitrary = do+ size <- elements [1..10]+ rpps <- replicateM size arbitrary+ let rpps' = filter (not . isSlurp) rpps+ extra <- arbitrary+ return $ RP $ rpps' ++ [extra]++caseOverlap' :: String -> String -> Bool -> Assertion+caseOverlap' x y b = do+ x' <- readRP x+ y' <- readRP y+ assert $ overlaps (unRP x') (unRP y') == b++caseOverlap1 :: Assertion+caseOverlap1 = caseOverlap' "/foo/$bar/" "/foo/baz/$bin" False+caseOverlap2 :: Assertion+caseOverlap2 = caseOverlap' "/foo/bar" "/foo/$baz" True+caseOverlap3 :: Assertion+caseOverlap3 = caseOverlap' "/foo/bar/baz/$bin" "*slurp" True++caseCheckPatterns :: Assertion+caseCheckPatterns = do+ let res = checkPatterns [p1, p2, p3, p4, p5]+ attempt helper (fail "Did not fail") res+ where+ p1 = cs "/foo/bar/baz"+ p2 = cs "/foo/$bar/baz"+ p3 = cs "/bin"+ p4 = cs "/bin/boo"+ p5 = cs "/bin/*slurp"+ expected = OverlappingPatterns+ [ (p1, p2)+ , (p4, p5)+ ]+ helper e = case cast e of+ Nothing -> fail "Wrong exception"+ Just op -> do+ expected @=? op++prop_showPattern :: RP -> Bool+prop_showPattern p = readRP (cs p) == Just p++caseIntegers :: Assertion+caseIntegers = do+ let p1 = "/foo/#bar/"+ p2 = "/foo/#baz/"+ p3 = "/foo/$bin/"+ p4 = "/foo/4/"+ p5 = "/foo/bar/"+ p6 = "/foo/*slurp/"+ checkOverlap :: String -> String -> Bool -> IO ()+ checkOverlap a b c = do+ rpa <- readRP a+ rpb <- readRP b+ let res1 = overlaps (unRP rpa) (unRP $ rpb)+ let res2 = overlaps (unRP rpb) (unRP $ rpa)+ when (res1 /= c || res2 /= c) $ assertString $ a+ ++ (if c then " does not overlap with " else " overlaps with ")+ ++ b+ checkOverlap p1 p2 True+ checkOverlap p1 p3 True+ checkOverlap p1 p4 True+ checkOverlap p1 p5 False+ checkOverlap p1 p6 True++instance Arbitrary RPP where+ arbitrary = do+ constr <- elements [Static, DynStr, Slurp, DynInt]+ size <- elements [1..10]+ s <- replicateM size $ elements ['a'..'z']+ return $ constr s++caseFromYaml :: Assertion+caseFromYaml = do+ rp1 <- readRP "static/*filepath"+ rp2 <- readRP "page"+ rp3 <- readRP "page/$page"+ rp4 <- readRP "user/#id"+ let expected =+ [ RPNode rp1 $ AllMethods "getStatic"+ , RPNode rp2 $ Methods [(GET, "pageIndex"), (PUT, "pageAdd")]+ , RPNode rp3 $ Methods [ (GET, "pageDetail")+ , (DELETE, "pageDelete")+ , (POST, "pageUpdate")+ ]+ , RPNode rp4 $ Methods [(GET, "userInfo")]+ ]+ contents' <- decodeFile "Test/resource-patterns.yaml"+ contents <- convertAttemptWrap (contents' :: TextObject)+ expected @=? contents++caseCheckRPNodes :: Assertion+caseCheckRPNodes = do+ good' <- decodeFile "Test/resource-patterns.yaml"+ good <- convertAttemptWrap (good' :: TextObject)+ Just good @=? checkRPNodes good+ rp1 <- readRP "foo/bar"+ rp2 <- readRP "$foo/bar"+ let bad1 = [ RPNode rp1 $ AllMethods "foo"+ , RPNode rp2 $ AllMethods "bar"+ ]+ Nothing @=? checkRPNodes bad1+ rp' <- readRP ""+ let bad2 = [RPNode rp' $ Methods [(GET, "foo"), (GET, "bar")]]+ Nothing @=? checkRPNodes bad2++caseReadRP :: Assertion+caseReadRP = do+ Just (RP [Static "foo", DynStr "bar", DynInt "baz", Slurp "bin"]) @=?+ readRP "foo/$bar/#baz/*bin/"+ Just (RP [Static "foo", DynStr "bar", DynInt "baz", Slurp "bin"]) @=?+ readRP "foo/$bar/#baz/*bin"+ Nothing @=? readRP "/foo//"+ Just (RP []) @=? readRP "/"+ Nothing @=? readRP "/*slurp/anything"+#endif
+ Yesod/Response.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE Rank2Types #-}+---------------------------------------------------------+--+-- Module : Yesod.Response+-- Copyright : Michael Snoyman+-- License : BSD3+--+-- Maintainer : Michael Snoyman <michael@snoyman.com>+-- Stability : Stable+-- Portability : portable+--+-- Generating responses.+--+---------------------------------------------------------+module Yesod.Response+ ( -- * Representations+ Content (..)+ , ChooseRep+ , HasReps (..)+ , defChooseRep+ , ioTextToContent+ , hoToJsonContent+ -- ** Convenience wrappers+ , staticRep+ -- ** Specific content types+ , RepHtml (..)+ , RepJson (..)+ , RepHtmlJson (..)+ -- * Response type+ , Response (..)+ -- * Special responses+ , RedirectType (..)+ , getRedirectStatus+ , SpecialResponse (..)+ -- * Error responses+ , ErrorResponse (..)+ , getStatus+ -- * Header+ , Header (..)+ , headerToPair+ -- * Converting to WAI values+ , responseToWaiResponse+#if TEST+ -- * Tests+ , testSuite+ , runContent+#endif+ ) where++import Data.Time.Clock+import Data.Maybe (mapMaybe)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Text.Lazy (Text)+import qualified Data.Text as T+import Data.Object.Json+import qualified Data.Text.Lazy.Encoding as DTLE++import Web.Encodings (formatW3)+import qualified Network.Wai as W+import qualified Network.Wai.Enumerator as WE++#if TEST+import Yesod.Request hiding (testSuite)+import Data.Object.Html hiding (testSuite)+import Web.Mime hiding (testSuite)+#else+import Yesod.Request+import Data.Object.Html+import Web.Mime+#endif++#if TEST+import Test.Framework (testGroup, Test)+#endif++data Content = ContentFile FilePath+ | ContentEnum (forall a.+ (a -> B.ByteString -> IO (Either a a))+ -> a+ -> IO (Either a a))++instance ConvertSuccess B.ByteString Content where+ convertSuccess bs = ContentEnum $ \f a -> f a bs+instance ConvertSuccess L.ByteString Content where+ convertSuccess = swapEnum . WE.fromLBS+instance ConvertSuccess T.Text Content where+ convertSuccess t = cs (cs t :: B.ByteString)+instance ConvertSuccess Text Content where+ convertSuccess lt = cs (cs lt :: L.ByteString)+instance ConvertSuccess String Content where+ convertSuccess s = cs (cs s :: Text)+instance ConvertSuccess HtmlDoc Content where+ convertSuccess = cs . unHtmlDoc+instance ConvertSuccess XmlDoc Content where+ convertSuccess = cs . unXmlDoc++type ChooseRep = [ContentType] -> IO (ContentType, Content)++-- | It would be nice to simplify 'Content' to the point where this is+-- unnecesary.+ioTextToContent :: IO Text -> Content+ioTextToContent = swapEnum . WE.fromLBS' . fmap DTLE.encodeUtf8++swapEnum :: W.Enumerator -> Content+swapEnum (W.Enumerator e) = ContentEnum e++hoToJsonContent :: HtmlObject -> Content+hoToJsonContent = cs . unJsonDoc . cs++-- | Any type which can be converted to representations.+class HasReps a where+ chooseRep :: a -> ChooseRep++-- | A helper method for generating 'HasReps' instances.+defChooseRep :: [(ContentType, a -> IO Content)] -> a -> ChooseRep+defChooseRep reps a ts = do+ let (ct, c) =+ case mapMaybe helper ts of+ (x:_) -> x+ [] -> case reps of+ [] -> error "Empty reps"+ (x:_) -> x+ c' <- c a+ return (ct, c')+ where+ helper ct = do+ c <- lookup ct reps+ return (ct, c)++instance HasReps ChooseRep where+ chooseRep = id++instance HasReps () where+ chooseRep = defChooseRep [(TypePlain, const $ return $ cs "")]++instance HasReps [(ContentType, Content)] where+ chooseRep a cts = return $+ case filter (\(ct, _) -> simpleContentType ct `elem`+ map simpleContentType cts) a of+ ((ct, c):_) -> (ct, c)+ _ -> case a of+ (x:_) -> x+ _ -> error "chooseRep [(ContentType, Content)] of empty"++instance HasReps (Html, HtmlObject) where+ chooseRep = defChooseRep+ [ (TypeHtml, return . cs . unHtmlDoc . cs)+ , (TypeJson, return . cs . unJsonDoc . cs)+ ]++-- | Data with a single representation.+staticRep :: ConvertSuccess x Content+ => ContentType+ -> x+ -> [(ContentType, Content)]+staticRep ct x = [(ct, cs x)]++newtype RepHtml = RepHtml Content+instance HasReps RepHtml where+ chooseRep (RepHtml c) _ = return (TypeHtml, c)+newtype RepJson = RepJson Content+instance HasReps RepJson where+ chooseRep (RepJson c) _ = return (TypeJson, c)+data RepHtmlJson = RepHtmlJson Content Content+instance HasReps RepHtmlJson where+ chooseRep (RepHtmlJson html json) = chooseRep+ [ (TypeHtml, html)+ , (TypeJson, json)+ ]++data Response = Response W.Status [Header] ContentType Content++-- | Different types of redirects.+data RedirectType = RedirectPermanent+ | RedirectTemporary+ | RedirectSeeOther+ deriving (Show, Eq)++getRedirectStatus :: RedirectType -> W.Status+getRedirectStatus RedirectPermanent = W.Status301+getRedirectStatus RedirectTemporary = W.Status302+getRedirectStatus RedirectSeeOther = W.Status303++-- | Special types of responses which should short-circuit normal response+-- processing.+data SpecialResponse =+ Redirect RedirectType String+ | SendFile ContentType FilePath+ deriving (Show, Eq)++-- | Responses to indicate some form of an error occurred. These are different+-- from 'SpecialResponse' in that they allow for custom error pages.+data ErrorResponse =+ NotFound+ | InternalError String+ | InvalidArgs [(ParamName, ParamError)]+ | PermissionDenied+ deriving (Show, Eq)++getStatus :: ErrorResponse -> W.Status+getStatus NotFound = W.Status404+getStatus (InternalError _) = W.Status500+getStatus (InvalidArgs _) = W.Status400+getStatus PermissionDenied = W.Status403++----- header stuff+-- | Headers to be added to a 'Result'.+data Header =+ AddCookie Int String String+ | DeleteCookie String+ | Header String String+ deriving (Eq, Show)++-- | Convert Header to a key/value pair.+headerToPair :: Header -> IO (W.ResponseHeader, B.ByteString)+headerToPair (AddCookie minutes key value) = do+ now <- getCurrentTime+ let expires = addUTCTime (fromIntegral $ minutes * 60) now+ return (W.SetCookie, cs $ key ++ "=" ++ value ++"; path=/; expires="+ ++ formatW3 expires)+headerToPair (DeleteCookie key) = return+ (W.SetCookie, cs $+ key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")+headerToPair (Header key value) =+ return (W.responseHeaderFromBS $ cs key, cs value)++responseToWaiResponse :: Response -> IO W.Response+responseToWaiResponse (Response sc hs ct c) = do+ hs' <- mapM headerToPair hs+ let hs'' = (W.ContentType, cs ct) : hs'+ return $ W.Response sc hs'' $ case c of+ ContentFile fp -> Left fp+ ContentEnum e -> Right $ W.Enumerator e++#if TEST+runContent :: Content -> IO L.ByteString+runContent (ContentFile fp) = L.readFile fp+runContent (ContentEnum c) = WE.toLBS $ W.Enumerator c++----- Testing+testSuite :: Test+testSuite = testGroup "Yesod.Response"+ [+ ]+#endif
+ Yesod/Template.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+module Yesod.Template+ ( YesodTemplate (..)+ , NoSuchTemplate+ , Template+ , TemplateGroup+ , loadTemplateGroup+ , defaultApplyLayout+ -- * HTML templates+ , HtmlTemplate (..)+ , templateHtml+ , templateHtmlJson+ , setHtmlAttrib+ ) where++import Data.Object.Html+import Data.Typeable (Typeable)+import Control.Exception (Exception)+import Data.Object.Text (Text)+import Text.StringTemplate+import Yesod.Response+import Yesod.Yesod+import Yesod.Handler+import Control.Monad (join)+import Yesod.Request (Request, getRequest)++type Template = StringTemplate Text+type TemplateGroup = STGroup Text++class Yesod y => YesodTemplate y where+ getTemplateGroup :: y -> TemplateGroup+ defaultTemplateAttribs :: y -> Request -> HtmlTemplate+ -> IO HtmlTemplate+ defaultTemplateAttribs _ _ = return++getTemplateGroup' :: YesodTemplate y => Handler y TemplateGroup+getTemplateGroup' = getTemplateGroup `fmap` getYesod++newtype NoSuchTemplate = NoSuchTemplate String+ deriving (Show, Typeable)+instance Exception NoSuchTemplate++loadTemplateGroup :: FilePath -> IO TemplateGroup+loadTemplateGroup = directoryGroupRecursiveLazy++defaultApplyLayout :: YesodTemplate y+ => y+ -> Request+ -> String -- ^ title+ -> Html -- ^ body+ -> Content+defaultApplyLayout y req t b =+ case getStringTemplate "layout" $ getTemplateGroup y of+ Nothing -> cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc)+ Just temp ->+ ioTextToContent+ $ fmap (render . unHtmlTemplate)+ $ defaultTemplateAttribs y req+ $ setHtmlAttrib "title" t+ $ setHtmlAttrib "content" b+ $ HtmlTemplate temp++type TemplateName = String+newtype HtmlTemplate = HtmlTemplate { unHtmlTemplate :: Template }++-- | Return a result using a template generating HTML alone.+templateHtml :: YesodTemplate y+ => TemplateName+ -> (HtmlTemplate -> IO HtmlTemplate)+ -> Handler y RepHtml+templateHtml tn f = do+ tg <- getTemplateGroup'+ y <- getYesod+ t <- case getStringTemplate tn tg of+ Nothing -> failure $ InternalError $ show $ NoSuchTemplate tn+ Just x -> return x+ rr <- getRequest+ return $ RepHtml $ ioTextToContent+ $ fmap (render . unHtmlTemplate)+ $ join+ $ fmap f+ $ defaultTemplateAttribs y rr+ $ HtmlTemplate t++setHtmlAttrib :: ConvertSuccess x HtmlObject+ => String -> x -> HtmlTemplate -> HtmlTemplate+setHtmlAttrib k v (HtmlTemplate t) =+ HtmlTemplate $ setAttribute k (toHtmlObject v) t++-- | Return a result using a template and 'HtmlObject' generating either HTML+-- or JSON output.+templateHtmlJson :: YesodTemplate y+ => TemplateName+ -> HtmlObject+ -> (HtmlObject -> HtmlTemplate -> IO HtmlTemplate)+ -> Handler y RepHtmlJson+templateHtmlJson tn ho f = do+ tg <- getTemplateGroup'+ y <- getYesod+ rr <- getRequest+ t <- case getStringTemplate tn tg of+ Nothing -> failure $ InternalError $ show $ NoSuchTemplate tn+ Just x -> return x+ return $ RepHtmlJson+ ( ioTextToContent+ $ fmap (render . unHtmlTemplate)+ $ join+ $ fmap (f ho)+ $ defaultTemplateAttribs y rr+ $ HtmlTemplate t+ )+ (hoToJsonContent ho)
+ Yesod/Yesod.hs view
@@ -0,0 +1,160 @@+-- | The basic typeclass for a Yesod application.+module Yesod.Yesod+ ( Yesod (..)+ , YesodApproot (..)+ , applyLayout'+ , applyLayoutJson+ , getApproot+ , toWaiApp+ , basicHandler+ ) where++import Data.Object.Html+import Data.Object.Json (unJsonDoc)+import Yesod.Response+import Yesod.Request+import Yesod.Definitions+import Yesod.Handler+import qualified Data.ByteString as B++import Data.Maybe (fromMaybe)+import Web.Mime+import Web.Encodings (parseHttpAccept)++import qualified Network.Wai as W+import Network.Wai.Middleware.CleanPath+import Network.Wai.Middleware.ClientSession+import Network.Wai.Middleware.Jsonp+import Network.Wai.Middleware.MethodOverride+import Network.Wai.Middleware.Gzip++import qualified Network.Wai.Handler.SimpleServer as SS+import qualified Network.Wai.Handler.CGI as CGI+import System.Environment (getEnvironment)++class Yesod a where+ -- | Please use the Quasi-Quoter, you\'ll be happier. For more information,+ -- see the examples/fact.lhs sample.+ resources :: Resource -> W.Method -> Handler a ChooseRep++ -- | The encryption key to be used for encrypting client sessions.+ encryptKey :: a -> IO Word256+ encryptKey _ = getKey defaultKeyFile++ -- | Number of minutes before a client session times out. Defaults to+ -- 120 (2 hours).+ clientSessionDuration :: a -> Int+ clientSessionDuration = const 120++ -- | Output error response pages.+ errorHandler :: ErrorResponse -> Handler a ChooseRep+ errorHandler = defaultErrorHandler++ -- | Applies some form of layout to <title> and <body> contents of a page.+ applyLayout :: a+ -> Request+ -> String -- ^ title+ -> Html -- ^ body+ -> Content+ applyLayout _ _ t b = cs (cs (Tag "title" [] $ cs t, b) :: HtmlDoc)++ -- | Gets called at the beginning of each request. Useful for logging.+ onRequest :: a -> Request -> IO ()+ onRequest _ _ = return ()++class Yesod a => YesodApproot a where+ -- | An absolute URL to the root of the application.+ approot :: a -> Approot++-- | A convenience wrapper around 'applyLayout'.+applyLayout' :: Yesod y+ => String+ -> Html+ -> Handler y ChooseRep+applyLayout' t b = do+ y <- getYesod+ rr <- getRequest+ return $ chooseRep+ [ (TypeHtml, applyLayout y rr t b)+ ]++-- | A convenience wrapper around 'applyLayout' which provides a JSON+-- representation of the body.+applyLayoutJson :: Yesod y+ => String+ -> HtmlObject+ -> Handler y ChooseRep+applyLayoutJson t b = do+ y <- getYesod+ rr <- getRequest+ return $ chooseRep+ [ (TypeHtml, applyLayout y rr t $ cs b)+ , (TypeJson, cs $ unJsonDoc $ cs b)+ ]++getApproot :: YesodApproot y => Handler y Approot+getApproot = approot `fmap` getYesod++defaultErrorHandler :: Yesod y+ => ErrorResponse+ -> Handler y ChooseRep+defaultErrorHandler NotFound = do+ r <- waiRequest+ applyLayout' "Not Found" $ cs $ toHtmlObject+ [ ("Not found", cs $ W.pathInfo r :: String)+ ]+defaultErrorHandler PermissionDenied =+ applyLayout' "Permission Denied" $ cs "Permission denied"+defaultErrorHandler (InvalidArgs ia) =+ applyLayout' "Invalid Arguments" $ cs $ toHtmlObject+ [ ("errorMsg", toHtmlObject "Invalid arguments")+ , ("messages", toHtmlObject ia)+ ]+defaultErrorHandler (InternalError e) =+ applyLayout' "Internal Server Error" $ cs $ toHtmlObject+ [ ("Internal server error", e)+ ]++toWaiApp :: Yesod y => y -> IO W.Application+toWaiApp a = do+ key <- encryptKey a+ let mins = clientSessionDuration a+ return $ gzip+ $ jsonp+ $ methodOverride+ $ cleanPath+ $ \thePath -> clientsession encryptedCookies key mins+ $ toWaiApp' a thePath++toWaiApp' :: Yesod y+ => y+ -> [B.ByteString]+ -> [(B.ByteString, B.ByteString)]+ -> W.Request+ -> IO W.Response+toWaiApp' y resource session env = do+ let types = httpAccept env+ handler = resources (map cs resource) $ W.requestMethod env+ rr <- parseWaiRequest env session+ onRequest y rr+ res <- runHandler handler errorHandler rr y types+ responseToWaiResponse res++httpAccept :: W.Request -> [ContentType]+httpAccept = map contentTypeFromBS+ . parseHttpAccept+ . fromMaybe B.empty+ . lookup W.Accept+ . W.requestHeaders++-- | Runs an application with CGI if CGI variables are present (namely+-- PATH_INFO); otherwise uses SimpleServer.+basicHandler :: Int -- ^ port number+ -> W.Application -> IO ()+basicHandler port app = do+ vars <- getEnvironment+ case lookup "PATH_INFO" vars of+ Nothing -> do+ putStrLn $ "http://localhost:" ++ show port ++ "/"+ SS.run port app+ Just _ -> CGI.run app
+ examples/fact.lhs view
@@ -0,0 +1,104 @@+> {-# LANGUAGE QuasiQuotes #-}++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.+++> instance Yesod Fact where++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.)++\begin{code}+ resources = [$mkResources|+/:+ GET: index+/#num:+ GET: fact+/fact:+ GET: factRedirect+|]+\end{code}++This does what it looks like: serves a static HTML file.++> index = 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).++> fact i = applyLayoutJson "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.++> factRedirect :: Handler y ()+> factRedirect = 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
+ examples/hellotemplate.lhs view
@@ -0,0 +1,33 @@+\begin{code}+{-# LANGUAGE QuasiQuotes #-}++import Yesod+import Network.Wai.Handler.SimpleServer++data HelloWorld = HelloWorld TemplateGroup+instance YesodTemplate HelloWorld where+ getTemplateGroup (HelloWorld tg) = tg+ defaultTemplateAttribs _ _ = return+ . setHtmlAttrib "default" "<DEFAULT>"+instance Yesod HelloWorld where+ resources = [$mkResources|+/:+ Get: helloWorld+/groups:+ Get: helloGroup+|]++helloWorld :: Handler HelloWorld RepHtml+helloWorld = templateHtml "template" $ return+ . setHtmlAttrib "title" "Hello world!"+ . setHtmlAttrib "content" "Hey look!! I'm <auto escaped>!"++helloGroup :: YesodTemplate y => Handler y RepHtmlJson+helloGroup = templateHtmlJson "real-template" (cs "bar") $ \ho ->+ return . setHtmlAttrib "foo" ho++main :: IO ()+main = do+ putStrLn "Running..."+ loadTemplateGroup "examples" >>= toWaiApp . HelloWorld >>= run 3000+\end{code}
+ examples/helloworld.lhs view
@@ -0,0 +1,19 @@+\begin{code}+{-# LANGUAGE QuasiQuotes #-}++import Yesod+import Network.Wai.Handler.SimpleServer++data HelloWorld = HelloWorld+instance Yesod HelloWorld where+ resources = [$mkResources|+/:+ Get: helloWorld+|]++helloWorld :: Handler HelloWorld ChooseRep+helloWorld = applyLayout' "Hello World" $ cs "Hello world!"++main :: IO ()+main = putStrLn "Running..." >> toWaiApp HelloWorld >>= run 3000+\end{code}
+ examples/i18n.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE QuasiQuotes #-}+import Yesod+import Network.Wai.Handler.SimpleServer++data I18N = I18N++instance Yesod I18N where+ resources = [$mkResources|+/:+ Get: homepage+/set/$lang:+ Get: setLang+|]++homepage :: Handler y [(ContentType, Content)]+homepage = 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++setLang :: String -> Handler y ()+setLang lang = do+ addCookie 1 langKey lang+ redirect RedirectTemporary "/"++main :: IO ()+main = putStrLn "Running..." >> toWaiApp I18N >>= run 3000
+ examples/pretty-yaml.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE QuasiQuotes #-}+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++data PY = PY TemplateGroup+instance YesodTemplate PY where+ getTemplateGroup (PY tg) = tg+ defaultTemplateAttribs _ _ = return+instance Yesod PY where+ resources = [$mkResources|+/:+ GET: homepageH+ POST: showYamlH+|]++homepageH :: Handler PY RepHtml+homepageH = templateHtml "pretty-yaml" return++showYamlH :: Handler PY RepHtmlJson+showYamlH = do+ rr <- getRequest+ (_, files) <- liftIO $ reqRequestBody rr+ fi <- case lookup "yaml" files of+ Nothing -> invalidArgs [("yaml", "Missing input")]+ Just x -> return x+ to <- liftIO $ decode $ B.concat $ L.toChunks $ fileContent fi+ let ho' = fmap Text to+ templateHtmlJson "pretty-yaml" ho' $ \ho ->+ return . setHtmlAttrib "yaml" (Scalar $ cs ho :: HtmlObject)++main :: IO ()+main = do+ putStrLn "Running..."+ loadTemplateGroup "examples" >>= toWaiApp . PY >>= run 3000
+ examples/tweedle.lhs view
@@ -0,0 +1,407 @@+#!/usr/bin/env runhaskell+> {-# LANGUAGE QuasiQuotes #-}++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)++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) TemplateGroup++(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 <- 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.++> instance Yesod Tweedle where++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.++> resources = [$mkResources|++Now we need to figure out all of the resources available in our application. We'll need a homepage:++> /:+> GET: homepageH++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: # notice that "id" is ignored by Yesod+> GET: categoryDetailsH+> PUT: createCategoryH+> /category/#id/issues:+> PUT: createIssueH+> /issue/#id:+> GET: issueDetailsH+> PUT: addMessageH+> |]++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 YesodApproot 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:++> homepageH :: Handler Tweedle ()+> homepageH = 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.++> categoryDetailsH :: 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.++> categoryDetailsH 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.++> createCategoryH :: Integer -> Handler Tweedle ()+> createCategoryH 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.++> createIssueH :: Integer -> Handler Tweedle ()+> createIssueH 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.++> issueDetailsH :: Integer -> Handler Tweedle RepHtmlJson+> issueDetailsH 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.++> addMessageH :: Integer -> Handler Tweedle ()+> addMessageH 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
+ runtests.hs view
@@ -0,0 +1,20 @@+import Test.Framework (defaultMain)++import qualified Yesod.Response+import qualified Yesod.Resource+import qualified Yesod.Request+import qualified Data.Object.Html+import qualified Test.Errors+import qualified Test.QuasiResource+import qualified Web.Mime++main :: IO ()+main = defaultMain+ [ Yesod.Response.testSuite+ , Yesod.Resource.testSuite+ , Yesod.Request.testSuite+ , Data.Object.Html.testSuite+ , Test.Errors.testSuite+ , Test.QuasiResource.testSuite+ , Web.Mime.testSuite+ ]
+ yesod.cabal view
@@ -0,0 +1,149 @@+name: yesod+version: 0.0.0+license: BSD3+license-file: LICENSE+author: Michael Snoyman <michael@snoyman.com>+maintainer: Michael Snoyman <michael@snoyman.com>+synopsis: A library for creating RESTful web applications.+description: This package stradles the line between framework and simply a controller. It provides minimal support for model and view, mostly focusing on making a controller which adheres strictly to RESTful principles.+category: Web+stability: unstable+cabal-version: >= 1.6+build-type: Simple+homepage: http://www.yesodweb.com/code.html+extra-source-files: CLI/skel/App.hs,+ CLI/skel/static/style.css,+ CLI/skel/settings.yaml,+ CLI/skel/LICENSE,+ CLI/skel/webapp.cabal,+ CLI/skel/templates/layout.st,+ CLI/skel/templates/homepage.st++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,+ old-locale >= 1.0.0.1 && < 1.1,+ time >= 1.1.3 && < 1.2,+ wai >= 0.0.0 && < 0.1,+ wai-extra >= 0.0.0 && < 0.1,+ split >= 0.1.1 && < 0.2,+ authenticate >= 0.4.0 && < 0.5,+ predicates >= 0.1 && < 0.2,+ bytestring >= 0.9.1.4 && < 0.10,+ web-encodings >= 0.2.4 && < 0.3,+ data-object >= 0.2.0 && < 0.3,+ data-object-yaml >= 0.2.0 && < 0.3,+ directory >= 1 && < 1.1,+ transformers >= 0.1.4.0 && < 0.2,+ control-monad-attempt >= 0.0.0 && < 0.1,+ syb,+ text >= 0.5 && < 0.8,+ convertible-text >= 0.2.0 && < 0.3,+ HStringTemplate >= 0.6.2 && < 0.7,+ data-object-json >= 0.0.0 && < 0.1,+ attempt >= 0.2.1 && < 0.3,+ template-haskell,+ failure >= 0.0.0 && < 0.1,+ safe-failure >= 0.4.0 && < 0.5+ exposed-modules: Yesod+ Yesod.Request+ Yesod.Response+ Yesod.Definitions+ Yesod.Form+ Yesod.Handler+ Yesod.Resource+ Yesod.Yesod+ Yesod.Template+ Data.Object.Html+ Yesod.Helpers.Auth+ Yesod.Helpers.Static+ Yesod.Helpers.AtomFeed+ Yesod.Helpers.Sitemap+ Web.Mime+ ghc-options: -Wall++executable yesod+ ghc-options: -Wall+ build-depends: file-embed >= 0.0.3 && < 0.1+ main-is: CLI/yesod.hs++executable runtests+ if flag(buildtests)+ Buildable: True+ cpp-options: -DTEST+ build-depends: test-framework,+ test-framework-quickcheck2,+ test-framework-hunit,+ HUnit,+ QuickCheck >= 2 && < 3+ else+ Buildable: False+ 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 hellotemplate+ if flag(buildsamples)+ Buildable: True+ else+ Buildable: False+ ghc-options: -Wall+ main-is: examples/hellotemplate.lhs++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