Removed Data.Object.Html and Yesod.Template
This commit is contained in:
Michael Snoyman
parent
572718bbd6
commit
5f7668334a
@ -1,252 +0,0 @@
|
||||
{-# 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
|
||||
9
Yesod.hs
9
Yesod.hs
@ -21,23 +21,21 @@ module Yesod
|
||||
, module Yesod.Handler
|
||||
, module Yesod.Resource
|
||||
, module Yesod.Form
|
||||
, module Data.Object.Html
|
||||
, module Yesod.Template
|
||||
, module Web.Mime
|
||||
, module Yesod.Hamlet
|
||||
, Application
|
||||
, Method (..)
|
||||
, cs
|
||||
) 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
|
||||
@ -47,4 +45,5 @@ import Yesod.Yesod
|
||||
import Yesod.Definitions
|
||||
import Yesod.Handler
|
||||
import Network.Wai (Application, Method (..))
|
||||
import Yesod.Template
|
||||
import Yesod.Hamlet
|
||||
import Data.Convertible.Text (cs)
|
||||
|
||||
@ -1,11 +1,16 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Yesod.Hamlet
|
||||
( hamletToContent
|
||||
, hamletToRepHtml
|
||||
, PageContent (..)
|
||||
, Hamlet
|
||||
, hamlet
|
||||
, simpleContent
|
||||
, HtmlContent (..)
|
||||
, HtmlObject
|
||||
)
|
||||
where
|
||||
|
||||
@ -13,8 +18,8 @@ import Text.Hamlet
|
||||
import Text.Hamlet.Monad (outputHtml)
|
||||
import Yesod.Response
|
||||
import Yesod.Handler
|
||||
import Data.Text (pack)
|
||||
import Data.Convertible.Text (cs)
|
||||
import Data.Convertible.Text
|
||||
import Data.Object
|
||||
|
||||
data PageContent url = PageContent
|
||||
{ pageTitle :: IO HtmlContent
|
||||
@ -22,13 +27,6 @@ data PageContent url = PageContent
|
||||
, pageBody :: Hamlet url IO ()
|
||||
}
|
||||
|
||||
simpleContent :: String -> HtmlContent -> PageContent url
|
||||
simpleContent title body = PageContent
|
||||
{ pageTitle = return $ Unencoded $ pack title
|
||||
, pageHead = return ()
|
||||
, pageBody = outputHtml body
|
||||
}
|
||||
|
||||
hamletToContent :: Hamlet (Routes y) IO () -> Handler y Content
|
||||
hamletToContent h = do
|
||||
render <- getUrlRender
|
||||
@ -45,3 +43,33 @@ hamletToRepHtml :: Hamlet (Routes y) IO () -> Handler y RepHtml
|
||||
hamletToRepHtml h = do
|
||||
c <- hamletToContent h
|
||||
return $ RepHtml c
|
||||
|
||||
instance Monad m => ConvertSuccess String (Hamlet url m ()) where
|
||||
convertSuccess = outputHtml . Unencoded . cs
|
||||
instance Monad m
|
||||
=> ConvertSuccess (Object String HtmlContent) (Hamlet url m ()) where
|
||||
convertSuccess (Scalar h) = outputHtml h
|
||||
convertSuccess (Sequence s) = template () where
|
||||
template = [$hamlet|
|
||||
%ul
|
||||
$forall s' s
|
||||
%li ^s^|]
|
||||
s' _ = return $ fromList $ map cs s
|
||||
convertSuccess (Mapping m) = template () where
|
||||
template :: Monad m => () -> Hamlet url m ()
|
||||
template = [$hamlet|
|
||||
%dl
|
||||
$forall pairs pair
|
||||
%dt $pair.key$
|
||||
%dd ^pair.val^|]
|
||||
pairs _ = return $ fromList $ map go m
|
||||
go (k, v) = Pair (return $ cs k) $ cs v
|
||||
instance ConvertSuccess String HtmlContent where
|
||||
convertSuccess = Unencoded . cs
|
||||
|
||||
data Pair url m = Pair { key :: m HtmlContent, val :: Hamlet url m () }
|
||||
|
||||
type HtmlObject = Object String HtmlContent
|
||||
|
||||
instance ConvertSuccess (Object String String) HtmlObject where
|
||||
convertSuccess = fmap cs
|
||||
|
||||
@ -52,10 +52,11 @@ 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
|
||||
|
||||
import Data.Convertible.Text (cs)
|
||||
|
||||
type family Routes y
|
||||
|
||||
data HandlerData yesod = HandlerData Request yesod (Routes yesod -> String)
|
||||
@ -155,8 +156,10 @@ sendFile ct = specialResponse . SendFile ct
|
||||
notFound :: Failure ErrorResponse m => m a
|
||||
notFound = failure NotFound
|
||||
|
||||
badMethod :: Failure ErrorResponse m => m a
|
||||
badMethod = failure BadMethod
|
||||
badMethod :: (RequestReader m, Failure ErrorResponse m) => m a
|
||||
badMethod = do
|
||||
w <- waiRequest
|
||||
failure $ BadMethod $ cs $ W.methodToBS $ W.requestMethod w
|
||||
|
||||
permissionDenied :: Failure ErrorResponse m => m a
|
||||
permissionDenied = failure PermissionDenied
|
||||
|
||||
@ -23,7 +23,8 @@ module Yesod.Helpers.AtomFeed
|
||||
|
||||
import Yesod
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Web.Encodings (formatW3)
|
||||
-- FIXME import Web.Encodings (formatW3)
|
||||
import Data.Convertible.Text
|
||||
|
||||
data AtomFeedResponse = AtomFeedResponse AtomFeed Approot
|
||||
|
||||
@ -48,11 +49,12 @@ data AtomFeedEntry = AtomFeedEntry
|
||||
{ atomEntryLink :: Location
|
||||
, atomEntryUpdated :: UTCTime
|
||||
, atomEntryTitle :: String
|
||||
, atomEntryContent :: Html
|
||||
, atomEntryContent :: HtmlContent
|
||||
}
|
||||
|
||||
instance ConvertSuccess AtomFeedResponse Content where
|
||||
convertSuccess = cs . (cs :: Html -> XmlDoc) . cs
|
||||
convertSuccess = error "FIXME" -- cs . (cs :: Html -> XmlDoc) . cs
|
||||
{- FIXME
|
||||
instance ConvertSuccess AtomFeedResponse Html where
|
||||
convertSuccess (AtomFeedResponse f ar) =
|
||||
Tag "feed" [("xmlns", "http://www.w3.org/2005/Atom")] $ HtmlList
|
||||
@ -75,3 +77,4 @@ instance ConvertSuccess (AtomFeedEntry, Approot) Html where
|
||||
, Tag "title" [] $ cs $ atomEntryTitle e
|
||||
, Tag "content" [("type", "html")] $ cdata $ atomEntryContent e
|
||||
]
|
||||
-}
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.Helpers.Auth
|
||||
@ -30,11 +31,11 @@ import qualified Web.Authenticate.Rpxnow as Rpxnow
|
||||
import qualified Web.Authenticate.OpenId as OpenId
|
||||
|
||||
import Yesod
|
||||
import Data.Convertible.Text
|
||||
|
||||
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)
|
||||
@ -90,11 +91,13 @@ authHandler W.GET ["openid", "complete"] = rc authOpenidComplete
|
||||
authHandler _ ["login", "rpxnow"] = rc rpxnowLogin
|
||||
authHandler _ _ = notFound
|
||||
|
||||
data OIDFormReq = OIDFormReq (Maybe String) (Maybe String)
|
||||
-- FIXME data OIDFormReq = OIDFormReq (Maybe String) (Maybe String)
|
||||
{- FIXME
|
||||
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)
|
||||
@ -106,20 +109,21 @@ authOpenidForm = do
|
||||
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
|
||||
let html = template (getParams rr "message")
|
||||
simpleApplyLayout "Log in via OpenID" html
|
||||
where
|
||||
urlForward _ = error "FIXME urlForward"
|
||||
hasMessage = return . not . null
|
||||
message [] = return $ Encoded $ cs ""
|
||||
message (m:_) = return $ Unencoded $ cs m
|
||||
template = [$hamlet|
|
||||
$if hasMessage
|
||||
%p.message $message$
|
||||
%form!method=get!action=@urlForward@
|
||||
%label!for=openid OpenID:
|
||||
%input#openid!type=text!name=openid
|
||||
%input!type=submit!value=Login
|
||||
|]
|
||||
|
||||
authOpenidForward :: YesodAuth y => Handler y ()
|
||||
authOpenidForward = do
|
||||
@ -190,12 +194,15 @@ getDisplayName (Rpxnow.Identifier ident extra) = helper choices where
|
||||
|
||||
authCheck :: Yesod y => Handler y ChooseRep
|
||||
authCheck = do
|
||||
ident <- maybeIdentifier
|
||||
dn <- displayName
|
||||
_ident <- maybeIdentifier
|
||||
_dn <- displayName
|
||||
error "FIXME applyLayoutJson"
|
||||
{-
|
||||
applyLayoutJson "Authentication Status" $ cs
|
||||
[ ("identifier", fromMaybe "" ident)
|
||||
, ("displayName", fromMaybe "" dn)
|
||||
]
|
||||
-}
|
||||
|
||||
authLogout :: YesodAuth y => Handler y ()
|
||||
authLogout = do
|
||||
|
||||
@ -24,8 +24,9 @@ module Yesod.Helpers.Sitemap
|
||||
) where
|
||||
|
||||
import Yesod
|
||||
import Web.Encodings (formatW3)
|
||||
--FIXME import Web.Encodings (formatW3)
|
||||
import Data.Time (UTCTime)
|
||||
import Data.Convertible.Text
|
||||
|
||||
data SitemapChangeFreq = Always
|
||||
| Hourly
|
||||
@ -42,8 +43,10 @@ instance ConvertSuccess SitemapChangeFreq String where
|
||||
convertSuccess Monthly = "monthly"
|
||||
convertSuccess Yearly = "yearly"
|
||||
convertSuccess Never = "never"
|
||||
{- FIXME
|
||||
instance ConvertSuccess SitemapChangeFreq Html where
|
||||
convertSuccess = (cs :: String -> Html) . cs
|
||||
-}
|
||||
|
||||
data SitemapUrl = SitemapUrl
|
||||
{ sitemapLoc :: Location
|
||||
@ -53,7 +56,8 @@ data SitemapUrl = SitemapUrl
|
||||
}
|
||||
data SitemapResponse = SitemapResponse [SitemapUrl] Approot
|
||||
instance ConvertSuccess SitemapResponse Content where
|
||||
convertSuccess = cs . (cs :: Html -> XmlDoc) . cs
|
||||
convertSuccess = error "FIXME" -- cs . (cs :: Html -> XmlDoc) . cs
|
||||
{- FIXME
|
||||
instance ConvertSuccess SitemapResponse Html where
|
||||
convertSuccess (SitemapResponse urls ar) =
|
||||
Tag "urlset" [("xmlns", sitemapNS)] $ HtmlList $ map helper urls
|
||||
@ -67,6 +71,7 @@ instance ConvertSuccess SitemapResponse Html where
|
||||
, Tag "changefreq" [] $ cs freq
|
||||
, Tag "priority" [] $ cs $ show pri
|
||||
]
|
||||
-}
|
||||
|
||||
instance HasReps SitemapResponse where
|
||||
chooseRep = defChooseRep
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in Hamlet
|
||||
---------------------------------------------------------
|
||||
--
|
||||
-- Module : Yesod.Helpers.Static
|
||||
|
||||
@ -49,6 +49,7 @@ import Control.Arrow ((***))
|
||||
import Data.Maybe (fromMaybe)
|
||||
import "transformers" Control.Monad.IO.Class
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad (liftM)
|
||||
|
||||
#if TEST
|
||||
import Test.Framework (testGroup, Test)
|
||||
@ -60,7 +61,7 @@ type ParamName = String
|
||||
type ParamValue = String
|
||||
type ParamError = String
|
||||
|
||||
class RequestReader m where
|
||||
class Monad m => RequestReader m where
|
||||
getRequest :: m Request
|
||||
instance RequestReader ((->) Request) where
|
||||
getRequest = id
|
||||
@ -69,8 +70,8 @@ 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
|
||||
waiRequest :: RequestReader m => m W.Request
|
||||
waiRequest = reqWaiRequest `liftM` getRequest
|
||||
|
||||
type RequestBodyContents =
|
||||
( [(ParamName, ParamValue)]
|
||||
|
||||
@ -25,7 +25,6 @@ module Yesod.Response
|
||||
, HasReps (..)
|
||||
, defChooseRep
|
||||
, ioTextToContent
|
||||
, hoToJsonContent
|
||||
-- ** Convenience wrappers
|
||||
, staticRep
|
||||
-- ** Specific content types
|
||||
@ -59,7 +58,7 @@ 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 Data.Convertible.Text
|
||||
|
||||
import Web.Encodings (formatW3)
|
||||
import qualified Network.Wai as W
|
||||
@ -67,11 +66,9 @@ 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
|
||||
|
||||
@ -95,10 +92,6 @@ 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)
|
||||
|
||||
@ -110,9 +103,6 @@ ioTextToContent = swapEnum . WE.fromLBS' . fmap cs
|
||||
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
|
||||
@ -148,12 +138,6 @@ instance HasReps [(ContentType, Content)] where
|
||||
(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
|
||||
@ -201,7 +185,7 @@ data ErrorResponse =
|
||||
| InternalError String
|
||||
| InvalidArgs [(ParamName, ParamError)]
|
||||
| PermissionDenied
|
||||
| BadMethod
|
||||
| BadMethod String
|
||||
deriving (Show, Eq)
|
||||
|
||||
getStatus :: ErrorResponse -> W.Status
|
||||
@ -209,6 +193,7 @@ getStatus NotFound = W.Status404
|
||||
getStatus (InternalError _) = W.Status500
|
||||
getStatus (InvalidArgs _) = W.Status400
|
||||
getStatus PermissionDenied = W.Status403
|
||||
getStatus (BadMethod _) = W.Status405
|
||||
|
||||
----- header stuff
|
||||
-- | Headers to be added to a 'Result'.
|
||||
|
||||
@ -1,113 +0,0 @@
|
||||
{-# 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)
|
||||
104
Yesod/Yesod.hs
104
Yesod/Yesod.hs
@ -3,15 +3,12 @@
|
||||
module Yesod.Yesod
|
||||
( Yesod (..)
|
||||
, YesodSite (..)
|
||||
, applyLayout'
|
||||
, applyLayoutJson
|
||||
, simpleApplyLayout
|
||||
, getApproot
|
||||
, toWaiApp
|
||||
, basicHandler
|
||||
) where
|
||||
|
||||
import Data.Object.Html
|
||||
import Data.Object.Json (unJsonDoc)
|
||||
import Yesod.Response
|
||||
import Yesod.Request
|
||||
import Yesod.Definitions
|
||||
@ -19,6 +16,8 @@ import Yesod.Hamlet
|
||||
import Yesod.Handler hiding (badMethod)
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Char8 as B8
|
||||
import Data.Convertible.Text
|
||||
import Text.Hamlet.Monad (fromList)
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Web.Mime
|
||||
@ -54,7 +53,7 @@ class YesodSite a => Yesod a where
|
||||
errorHandler :: Yesod y => a -> ErrorResponse -> Handler y ChooseRep
|
||||
errorHandler _ = defaultErrorHandler
|
||||
|
||||
-- | Applies some form of layout to <title> and <body> contents of a page.
|
||||
-- | Applies some form of layout to <title> and <body> contents of a page. FIXME: use a Maybe here to allow subsites to simply inherit.
|
||||
applyLayout :: a
|
||||
-> PageContent (Routes a)
|
||||
-> Request
|
||||
@ -77,13 +76,17 @@ class YesodSite a => Yesod a where
|
||||
-- trailing slash.
|
||||
approot :: a -> Approot
|
||||
|
||||
-- | A convenience wrapper around 'applyLayout'.
|
||||
applyLayout' :: Yesod y
|
||||
=> String
|
||||
-> Html
|
||||
-> Handler y ChooseRep
|
||||
applyLayout' t b = do
|
||||
let pc = simpleContent t $ Encoded $ cs $ unHtmlFragment $ cs b
|
||||
-- | A convenience wrapper around 'simpleApplyLayout for HTML-only data.
|
||||
simpleApplyLayout :: Yesod y
|
||||
=> String -- ^ title
|
||||
-> Hamlet (Routes y) IO () -- ^ body
|
||||
-> Handler y ChooseRep
|
||||
simpleApplyLayout t b = do
|
||||
let pc = PageContent
|
||||
{ pageTitle = return $ Unencoded $ cs t
|
||||
, pageHead = return ()
|
||||
, pageBody = b
|
||||
}
|
||||
y <- getYesod
|
||||
rr <- getRequest
|
||||
content <- hamletToContent $ applyLayout y pc rr
|
||||
@ -91,55 +94,60 @@ applyLayout' t b = do
|
||||
[ (TypeHtml, content)
|
||||
]
|
||||
|
||||
-- | 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
|
||||
let pc = simpleContent t $ Encoded $ cs $ unHtmlFragment
|
||||
$ cs (cs b :: Html)
|
||||
y <- getYesod
|
||||
rr <- getRequest
|
||||
htmlcontent <- hamletToContent $ applyLayout y pc rr
|
||||
return $ chooseRep
|
||||
[ (TypeHtml, htmlcontent)
|
||||
, (TypeJson, cs $ unJsonDoc $ cs b)
|
||||
]
|
||||
|
||||
getApproot :: Yesod 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)
|
||||
]
|
||||
simpleApplyLayout "Not Found" $ [$hamlet|
|
||||
%h1 Not Found
|
||||
%p $helper$
|
||||
|] r
|
||||
where
|
||||
helper = return . Unencoded . cs . W.pathInfo
|
||||
defaultErrorHandler PermissionDenied =
|
||||
applyLayout' "Permission Denied" $ cs "Permission denied"
|
||||
simpleApplyLayout "Permission Denied" $ [$hamlet|
|
||||
%h1 Permission denied|] ()
|
||||
defaultErrorHandler (InvalidArgs ia) =
|
||||
applyLayout' "Invalid Arguments" $ cs $ toHtmlObject
|
||||
[ ("errorMsg", toHtmlObject "Invalid arguments")
|
||||
, ("messages", toHtmlObject ia)
|
||||
]
|
||||
simpleApplyLayout "Invalid Arguments" $ [$hamlet|
|
||||
%h1 Invalid Arguments
|
||||
%dl
|
||||
$forall ias pair
|
||||
%dt $pair.key$
|
||||
%dd $pair.val$
|
||||
|] ()
|
||||
where
|
||||
ias _ = return $ fromList $ map go ia
|
||||
go (k, v) = Pair (return $ Unencoded $ cs k)
|
||||
(return $ Unencoded $ cs v)
|
||||
defaultErrorHandler (InternalError e) =
|
||||
applyLayout' "Internal Server Error" $ cs $ toHtmlObject
|
||||
[ ("Internal server error", e)
|
||||
]
|
||||
defaultErrorHandler BadMethod =
|
||||
applyLayout' "Bad Method" $ cs "Method Not Supported"
|
||||
simpleApplyLayout "Internal Server Error" $ [$hamlet|
|
||||
%h1 Internal Server Error
|
||||
%p $message$
|
||||
|] e
|
||||
where
|
||||
message :: String -> IO HtmlContent
|
||||
message = return . Unencoded . cs
|
||||
defaultErrorHandler (BadMethod m) =
|
||||
simpleApplyLayout "Bad Method" $ [$hamlet|
|
||||
%h1 Method Not Supported
|
||||
%p Method "$m'$" not supported
|
||||
|] ()
|
||||
where
|
||||
m' _ = return $ Unencoded $ cs m
|
||||
|
||||
data Pair m k v = Pair { key :: m k, val :: m v }
|
||||
|
||||
toWaiApp :: Yesod y => y -> IO W.Application
|
||||
toWaiApp a = do
|
||||
key <- encryptKey a
|
||||
key' <- encryptKey a
|
||||
let mins = clientSessionDuration a
|
||||
return $ gzip
|
||||
$ jsonp
|
||||
$ methodOverride
|
||||
$ cleanPath
|
||||
$ \thePath -> clientsession encryptedCookies key mins
|
||||
$ \thePath -> clientsession encryptedCookies key' mins
|
||||
$ toWaiApp' a thePath
|
||||
|
||||
toWaiApp' :: Yesod y
|
||||
@ -161,7 +169,8 @@ toWaiApp' y resource session env = do
|
||||
print pathSegments
|
||||
let ya = case eurl of
|
||||
Left _ -> runHandler (errorHandler y NotFound) y render
|
||||
Right url -> handleSite site render url method badMethod y
|
||||
Right url -> handleSite site render url method
|
||||
(badMethod method) y
|
||||
let eh er = runHandler (errorHandler y er) y render
|
||||
unYesodApp ya eh rr types >>= responseToWaiResponse
|
||||
|
||||
@ -187,8 +196,9 @@ basicHandler port app = do
|
||||
SS.run port app
|
||||
Just _ -> CGI.run app
|
||||
|
||||
badMethod :: YesodApp
|
||||
badMethod = YesodApp $ \eh req cts -> unYesodApp (eh BadMethod) eh req cts
|
||||
badMethod :: String -> YesodApp
|
||||
badMethod m = YesodApp $ \eh req cts
|
||||
-> unYesodApp (eh $ BadMethod m) eh req cts
|
||||
|
||||
fixSegs :: [String] -> [String]
|
||||
fixSegs [] = []
|
||||
|
||||
@ -79,10 +79,11 @@ data, all with HTML entities escaped properly. These representations include:
|
||||
For simplicity here, we don't include a template, though it would be trivial to
|
||||
do so (see the hellotemplate example).
|
||||
|
||||
> getFactR i = applyLayoutJson "Factorial result" $ cs
|
||||
> getFactR :: Integer -> Handler y ChooseRep -- FIXME remove
|
||||
> getFactR _i = error "FIXME" {-simpleApplyLayout "Factorial result" $ cs
|
||||
> [ ("input", show i)
|
||||
> , ("result", show $ product [1..fromIntegral i :: Integer])
|
||||
> ]
|
||||
> ]-}
|
||||
|
||||
I've decided to have a redirect instead of serving the some data in two
|
||||
locations. It fits in more properly with the RESTful principal of one name for
|
||||
|
||||
@ -4,7 +4,6 @@
|
||||
|
||||
import Yesod
|
||||
import Network.Wai.Handler.SimpleServer
|
||||
import Text.Hamlet
|
||||
|
||||
data Ham = Ham
|
||||
|
||||
@ -21,7 +20,7 @@ data NextLink m = NextLink { nextLink :: m HamRoutes }
|
||||
nl :: Monad m => HamRoutes -> NextLink m
|
||||
nl = NextLink . return
|
||||
|
||||
template :: Monad m => NextLink (Hamlet HamRoutes m) -> Hamlet HamRoutes m ()
|
||||
template :: Monad m => NextLink m -> Hamlet HamRoutes m ()
|
||||
template = [$hamlet|
|
||||
%a!href=@nextLink@ Next page
|
||||
|]
|
||||
|
||||
@ -1,36 +0,0 @@
|
||||
\begin{code}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
import Yesod
|
||||
import Network.Wai.Handler.SimpleServer
|
||||
|
||||
data HelloWorld = HelloWorld TemplateGroup
|
||||
|
||||
mkYesod "HelloWorld" [$parseRoutes|
|
||||
/ Home GET
|
||||
/groups Group GET
|
||||
|]
|
||||
|
||||
instance Yesod HelloWorld where
|
||||
approot _ = "http://localhost:3000"
|
||||
instance YesodTemplate HelloWorld where
|
||||
getTemplateGroup (HelloWorld tg) = tg
|
||||
defaultTemplateAttribs _ _ = return
|
||||
. setHtmlAttrib "default" "<DEFAULT>"
|
||||
|
||||
getHome :: Handler HelloWorld RepHtml
|
||||
getHome = templateHtml "template" $ return
|
||||
. setHtmlAttrib "title" "Hello world!"
|
||||
. setHtmlAttrib "content" "Hey look!! I'm <auto escaped>!"
|
||||
|
||||
getGroup :: YesodTemplate y => Handler y RepHtmlJson
|
||||
getGroup = templateHtmlJson "real-template" (cs "bar") $ \ho ->
|
||||
return . setHtmlAttrib "foo" ho
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "Running..."
|
||||
loadTemplateGroup "examples" >>= toWaiApp . HelloWorld >>= run 3000
|
||||
\end{code}
|
||||
@ -16,7 +16,7 @@ instance Yesod HelloWorld where
|
||||
approot _ = "http://localhost:3000"
|
||||
|
||||
getHome :: Handler HelloWorld ChooseRep
|
||||
getHome = applyLayout' "Hello World" $ cs "Hello world!"
|
||||
getHome = simpleApplyLayout "Hello World" $ cs "Hello world!"
|
||||
|
||||
main :: IO ()
|
||||
main = putStrLn "Running..." >> toWaiApp HelloWorld >>= run 3000
|
||||
|
||||
@ -8,35 +8,60 @@ import Network.Wai.Handler.SimpleServer
|
||||
import Web.Encodings
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Object.String
|
||||
|
||||
data PY = PY TemplateGroup
|
||||
data PY = PY
|
||||
|
||||
mkYesod "PY" [$parseRoutes|
|
||||
/ Homepage GET POST
|
||||
|]
|
||||
|
||||
instance YesodTemplate PY where
|
||||
getTemplateGroup (PY tg) = tg
|
||||
defaultTemplateAttribs _ _ = return
|
||||
instance Yesod PY where
|
||||
approot _ = "http://localhost:3000"
|
||||
|
||||
getHomepage :: Handler PY RepHtml
|
||||
getHomepage = templateHtml "pretty-yaml" return
|
||||
template :: Monad m => TempArgs url m -> Hamlet url m ()
|
||||
template = [$hamlet|
|
||||
!!!
|
||||
%html
|
||||
%head
|
||||
%meta!charset=utf-8
|
||||
%title Pretty YAML
|
||||
%body
|
||||
%form!method=post!action=.!enctype=multipart/form-data
|
||||
File name:
|
||||
%input!type=file!name=yaml
|
||||
%input!type=submit
|
||||
$if hasYaml
|
||||
%div ^yaml^
|
||||
|]
|
||||
|
||||
postHomepage :: Handler PY RepHtmlJson
|
||||
data TempArgs url m = TempArgs
|
||||
{ hasYaml :: m Bool
|
||||
, yaml :: Hamlet url m ()
|
||||
}
|
||||
|
||||
getHomepage :: Handler PY RepHtml
|
||||
getHomepage = hamletToRepHtml
|
||||
$ template $ TempArgs (return False) (return ())
|
||||
|
||||
--FIXMEpostHomepage :: Handler PY RepHtmlJson
|
||||
postHomepage :: Handler PY RepHtml
|
||||
postHomepage = do
|
||||
rr <- getRequest
|
||||
(_, files) <- liftIO $ reqRequestBody rr
|
||||
fi <- case lookup "yaml" files of
|
||||
Nothing -> invalidArgs [("yaml", "Missing input")]
|
||||
Just x -> return x
|
||||
to <- liftIO $ decode $ B.concat $ L.toChunks $ fileContent fi
|
||||
so <- 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)
|
||||
-}
|
||||
let ho = cs (so :: StringObject) :: HtmlObject
|
||||
hamletToRepHtml $ template $ TempArgs (return True) (cs ho)
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
putStrLn "Running..."
|
||||
loadTemplateGroup "examples" >>= toWaiApp . PY >>= run 3000
|
||||
toWaiApp PY >>= run 3000
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} -- FIXME due to bug in Hamlet
|
||||
|
||||
import Yesod
|
||||
import Yesod.Helpers.Static
|
||||
|
||||
@ -34,7 +34,7 @@ One of the goals of Yesod is to make it work with the compiler to help you progr
|
||||
|
||||
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
|
||||
> data Tweedle = Tweedle Settings (MVar Category)
|
||||
|
||||
(For now, just ignore the TemplateGroup, its purpose becomes apparent later.)
|
||||
|
||||
@ -149,7 +149,7 @@ Note that this will die unless an issues file is present. We could instead check
|
||||
> issuesSO <- decodeFile $ issueFile settings
|
||||
> issues <- fromAttempt $ categoryFromSO issuesSO
|
||||
> missues <- newMVar issues
|
||||
> tg <- loadTemplateGroup $ templatesDir settings
|
||||
> tg <- error "FIXME switch to hamlet" -- loadTemplateGroup $ templatesDir settings
|
||||
> return $ Tweedle settings missues tg
|
||||
|
||||
And now we're going to write our main function. Yesod is built on top of the Web Application Interface (wai package), so a Yesod application runs on a variety of backends. For our purposes, we're going to use the SimpleServer.
|
||||
|
||||
10
yesod.cabal
10
yesod.cabal
@ -53,7 +53,6 @@ library
|
||||
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,
|
||||
@ -71,8 +70,6 @@ library
|
||||
Yesod.Handler
|
||||
Yesod.Resource
|
||||
Yesod.Yesod
|
||||
Yesod.Template
|
||||
Data.Object.Html
|
||||
Yesod.Helpers.Auth
|
||||
Yesod.Helpers.Static
|
||||
Yesod.Helpers.AtomFeed
|
||||
@ -82,7 +79,8 @@ library
|
||||
|
||||
executable yesod
|
||||
ghc-options: -Wall
|
||||
build-depends: file-embed >= 0.0.3 && < 0.1
|
||||
build-depends: file-embed >= 0.0.3 && < 0.1,
|
||||
HStringTemplate >= 0.6.2 && < 0.7
|
||||
main-is: CLI/yesod.hs
|
||||
|
||||
executable runtests
|
||||
@ -107,13 +105,13 @@ executable helloworld
|
||||
ghc-options: -Wall
|
||||
main-is: examples/helloworld.lhs
|
||||
|
||||
executable hellotemplate
|
||||
executable hamlet
|
||||
if flag(buildsamples)
|
||||
Buildable: True
|
||||
else
|
||||
Buildable: False
|
||||
ghc-options: -Wall
|
||||
main-is: examples/hellotemplate.lhs
|
||||
main-is: examples/hamlet.hs
|
||||
|
||||
executable fact
|
||||
if flag(buildsamples)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user